From 576fafbf26c577ec61c5427b4d2e91948fae5205 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 4 Sep 2019 14:48:18 -0600 Subject: [PATCH 001/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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/137] 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 80743e6cbbbe70092a65c87e833bd953dc30fe19 Mon Sep 17 00:00:00 2001 From: "jessica.meixner" Date: Fri, 25 Oct 2019 12:43:06 -0400 Subject: [PATCH 056/137] Adding river runoff (from Jiande) Squashed commit of the following: commit 8aa45c6a0cc8bbf98c0e823a8994a4d0383e3d0b Author: jiandewang Date: Mon Sep 23 22:45:46 2019 -0400 fix typo in cap commit ad85f5a9aefe57ff790ee9afe81624494c5dd987 Merge: 4f71b04 c7d2a71 Author: jiandewang Date: Mon Sep 23 13:48:07 2019 -0400 solve conflict in mom cap commit 4f71b04369a1be10b4f8ac9f446512ee108d63cb Author: jiandewang Date: Sat Aug 17 21:08:44 2019 -0400 add ifndef CESMCOUPLED in cap for EMC runoff commit 258a19c7e86a863979cc9e8feb1b789e6c1f6fce Author: jiandewang Date: Sun Aug 4 19:30:08 2019 -0400 add runoff in mom_cap.F90 --- config_src/nuopc_driver/mom_cap.F90 | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 1aeaaa7a3a..3b36628b9a 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -313,6 +313,7 @@ !> This module contains a set of subroutines that are required by NUOPC. module MOM_cap_mod use constants_mod, only: constants_init +use data_override_mod, only: data_override_init, data_override use diag_manager_mod, only: diag_manager_init, diag_manager_end use field_manager_mod, only: field_manager_init, field_manager_end use fms_mod, only: fms_init, fms_end, open_namelist_file, check_nml_error @@ -976,6 +977,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ocean_model_init(ocean_public, ocean_state, Time, Time) endif +#ifndef CESMCOUPLED +! for runoff in EMC + call data_override_init(Ocean_domain_in = Ocean_public%domain) +#endif + call ocean_model_init_sfc(ocean_state, ocean_public) call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) @@ -1922,6 +1928,8 @@ subroutine ModelAdvance(gcomp, rc) file=__FILE__)) & return ! bail out + call ice_ocn_bnd_from_data(Ice_ocean_boundary, Time, Time_step_coupled) ! for runoff + !--------------- ! Update MOM6 !--------------- @@ -2525,4 +2533,18 @@ subroutine shr_file_getLogUnit(nunit) end subroutine shr_file_getLogUnit #endif -end module MOM_cap_mod + subroutine ice_ocn_bnd_from_data(x, Time, Time_step_coupled) +! get forcing data from data_overide + type (ice_ocean_boundary_type) :: x + type(Time_type), intent(in) :: Time, Time_step_coupled + + type(Time_type) :: Time_next + character(len=*),parameter :: subname='(mom_cap:ice_ocn_bnd_from_data)' + + Time_next = Time + Time_step_coupled +! call data_override('OCN', 'runoff', x%runoff , Time_next) + call data_override('OCN', 'runoff', x%rofl_flux , Time_next) + + end subroutine ice_ocn_bnd_from_data + +end module mom_cap_mod From 07481e41d7ac400a5682b186da97670651ec09ba Mon Sep 17 00:00:00 2001 From: "Jessica.Meixner" Date: Fri, 8 Nov 2019 16:51:23 +0000 Subject: [PATCH 057/137] updating mom_cap to add data override which was deleted in merge --- config_src/nuopc_driver/mom_cap.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index ef3766d2ba..804dacce9e 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -41,6 +41,7 @@ module MOM_cap_mod use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit #endif use time_utils_mod, only: esmf2fms_time +use data_override_mod, only: data_override_init, data_override use, intrinsic :: iso_fortran_env, only: output_unit From 419a021d90d1fcd4aba523c41605ce89f673db0c Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sat, 16 Nov 2019 14:25:46 +0000 Subject: [PATCH 058/137] removes data_override and associated calls from mom_cap renames: iob%rofl_flux => iob%lrunoff iob%rofi_flux => iob%frunoff iob%runoff_hflx = > iob%lrunoff_hflx iob%calving_hflx => iob%frunoff_hflx makes changes in mom_cap_methods and mom_surface_forcing_nuopc consistent w/ new iob names temporarily comments out _hflx terms in mom_cap,mom_cap_methods adds flag in mom_surface_forcing_nuopc for adding liquid river runoff via data_override --- config_src/nuopc_driver/mom_cap.F90 | 42 +++--------- config_src/nuopc_driver/mom_cap_methods.F90 | 66 +++++++------------ .../mom_surface_forcing_nuopc.F90 | 50 ++++++++------ 3 files changed, 59 insertions(+), 99 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 804dacce9e..50df123264 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -41,7 +41,6 @@ module MOM_cap_mod use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit #endif use time_utils_mod, only: esmf2fms_time -use data_override_mod, only: data_override_init, data_override use, intrinsic :: iso_fortran_env, only: output_unit @@ -689,11 +688,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ocean_public%is_ocean_pe = .true. call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfile)) -#ifndef CESMCOUPLED -! for runoff in EMC - call data_override_init(Ocean_domain_in = Ocean_public%domain) -#endif - call ocean_model_init_sfc(ocean_state, ocean_public) call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) @@ -714,12 +708,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & Ice_ocean_boundary% mi (isc:iec,jsc:jec), & Ice_ocean_boundary% p (isc:iec,jsc:jec), & - Ice_ocean_boundary% runoff (isc:iec,jsc:jec), & - Ice_ocean_boundary% calving (isc:iec,jsc:jec), & - Ice_ocean_boundary% runoff_hflx (isc:iec,jsc:jec), & - Ice_ocean_boundary% calving_hflx (isc:iec,jsc:jec), & - Ice_ocean_boundary% rofl_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% rofi_flux (isc:iec,jsc:jec)) + !Ice_ocean_boundary% lrunoff_hflx (isc:iec,jsc:jec), & + !Ice_ocean_boundary% frunoff_hflx (isc:iec,jsc:jec), & + Ice_ocean_boundary% lrunoff (isc:iec,jsc:jec), & + Ice_ocean_boundary% frunoff (isc:iec,jsc:jec)) Ice_ocean_boundary%u_flux = 0.0 Ice_ocean_boundary%v_flux = 0.0 @@ -737,12 +729,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%seaice_melt_heat= 0.0 Ice_ocean_boundary%mi = 0.0 Ice_ocean_boundary%p = 0.0 - Ice_ocean_boundary%runoff = 0.0 - Ice_ocean_boundary%calving = 0.0 - Ice_ocean_boundary%runoff_hflx = 0.0 - Ice_ocean_boundary%calving_hflx = 0.0 - Ice_ocean_boundary%rofl_flux = 0.0 - Ice_ocean_boundary%rofi_flux = 0.0 + !Ice_ocean_boundary%lrunoff_hflx = 0.0 + !Ice_ocean_boundary%frunoff_hflx = 0.0 + Ice_ocean_boundary%lrunoff = 0.0 + Ice_ocean_boundary%frunoff = 0.0 ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) @@ -787,8 +777,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fresh_water_to_ocean_rate", "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "net_heat_flx_to_ocn" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_rate" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_rate" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") @@ -2332,20 +2320,6 @@ subroutine shr_file_getLogUnit(nunit) end subroutine shr_file_getLogUnit #endif - subroutine ice_ocn_bnd_from_data(x, Time, Time_step_coupled) -! get forcing data from data_overide - type (ice_ocean_boundary_type) :: x - type(Time_type), intent(in) :: Time, Time_step_coupled - - type(Time_type) :: Time_next - character(len=*),parameter :: subname='(mom_cap:ice_ocn_bnd_from_data)' - - Time_next = Time + Time_step_coupled -! call data_override('OCN', 'runoff', x%runoff , Time_next) - call data_override('OCN', 'runoff', x%rofl_flux , Time_next) - - end subroutine ice_ocn_bnd_from_data - !> !! @page nuopc_cap NUOPC Cap !! @author Fei Liu (fei.liu@gmail.com) diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 2f872c7da5..9d1278f25d 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -214,68 +214,46 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, return ! bail out !---- - ! runoff and heat content of runoff + ! mass and heat content of liquid and frozen runoff !---- ! Note - preset values to 0, if field does not exist in importState, then will simply return ! and preset value will be used ! liquid runoff - ice_ocean_boundary%rofl_flux (:,:) = 0._ESMF_KIND_R8 + ice_ocean_boundary%lrunoff (:,:) = 0._ESMF_KIND_R8 call state_getimport(importState, 'Foxx_rofl', & - isc, iec, jsc, jec, ice_ocean_boundary%rofl_flux,rc=rc) + isc, iec, jsc, jec, ice_ocean_boundary%lrunoff,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & return ! bail out ! ice runoff - ice_ocean_boundary%rofi_flux (:,:) = 0._ESMF_KIND_R8 + ice_ocean_boundary%frunoff (:,:) = 0._ESMF_KIND_R8 call state_getimport(importState, 'Foxx_rofi', & - isc, iec, jsc, jec, ice_ocean_boundary%rofi_flux,rc=rc) + isc, iec, jsc, jec, ice_ocean_boundary%frunoff,rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & return ! bail out - ! total runoff - ice_ocean_boundary%runoff (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_runoff_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%runoff, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! heat content of runoff - ice_ocean_boundary%runoff_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_runoff_heat_flux', & - isc, iec, jsc, jec, ice_ocean_boundary%runoff_hflx, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - !---- - ! calving rate and heat flux - !---- - ! Note - preset values to 0, if field does not exist in importState, then will simply return - ! and preset value will be used - - ice_ocean_boundary%calving(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_calving_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%calving, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ice_ocean_boundary%calving_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_calving_heat_flux', & - isc, iec, jsc, jec, ice_ocean_boundary%calving_hflx, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + ! heat content of lrunoff + !ice_ocean_boundary%lrunoff_hflx(:,:) = 0._ESMF_KIND_R8 + !call state_getimport(importState, 'liquid_runoff_heat_flx', & + ! isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_hflx, rc=rc) + !if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + ! line=__LINE__, & + ! file=__FILE__)) & + ! return ! bail out + + ! heat content of frunoff + !ice_ocean_boundary%frunoff_hflx(:,:) = 0._ESMF_KIND_R8 + !call state_getimport(importState, 'frozen_runoff_heat_flx', & + ! isc, iec, jsc, jec, ice_ocean_boundary%frunoff_hflx, rc=rc) + !if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + ! line=__LINE__, & + ! file=__FILE__)) & + ! return ! bail out !---- ! salt flux from ice diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index ba6760ffa4..4ad84b353c 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -107,6 +107,7 @@ module MOM_surface_forcing_nuopc !! sea-ice viscosity becomes effective, in kg m-2, !! typically of order 1000 [kg m-2]. logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments + logical :: liquid_runoff_from_data !< If true, use data_override to obtain liquid runoff real :: Flux_const !< piston velocity for surface restoring [m/s] logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux @@ -152,8 +153,8 @@ module MOM_surface_forcing_nuopc !> Structure corresponding to forcing, but with the elements, units, and conventions !! that exactly conform to the use for MOM-based coupled models. type, public :: ice_ocean_boundary_type - real, pointer, dimension(:,:) :: rofl_flux =>NULL() !< liquid runoff [kg/m2/s] - real, pointer, dimension(:,:) :: rofi_flux =>NULL() !< ice runoff [kg/m2/s] + real, pointer, dimension(:,:) :: lrunoff =>NULL() !< liquid runoff [kg/m2/s] + real, pointer, dimension(:,:) :: frunoff =>NULL() !< ice runoff [kg/m2/s] real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress [Pa] real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress [Pa] real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W/m2] @@ -168,13 +169,11 @@ module MOM_surface_forcing_nuopc real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation [W/m2] real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip [kg/m2/s] real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip [kg/m2/s] - real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff [kg/m2/s] - real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff [kg/m2/s] real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m/s] real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs[m2/m2] real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) - real, pointer, dimension(:,:) :: runoff_hflx =>NULL() !< heat content of liquid runoff [W/m2] - real, pointer, dimension(:,:) :: calving_hflx =>NULL() !< heat content of frozen runoff [W/m2] + !real, pointer, dimension(:,:) :: lrunoff_hflx =>NULL() !< heat content of liquid runoff [W/m2] + !real, pointer, dimension(:,:) :: frunoff_hflx =>NULL() !< heat content of frozen runoff [W/m2] real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere !< on ocean surface [Pa] real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice [kg/m2] @@ -411,6 +410,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & enddo ; enddo endif + ! Check that liquid runoff has a place to go + if (CS%liquid_runoff_from_data .and. .not. associated(IOB%lrunoff)) then + call MOM_error(FATAL, "liquid runoff is being added via data_override but "// & + "there is no associated runoff in the IOB%") + return + end if + ! obtain fluxes from IOB; note the staggering of indices i0 = is - isc_bnd ; j0 = js - jsc_bnd do j=js,je ; do i=is,ie @@ -425,17 +431,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & fluxes%evap(i,j) = IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) ! liquid runoff flux - if (associated(IOB%rofl_flux)) then - fluxes%lrunoff(i,j) = IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) - else if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%lrunoff)) then + if(CS%liquid_runoff_from_data)call data_override('OCN', 'runoff', IOB%lrunoff, Time) + fluxes%lrunoff(i,j) = IOB%lrunoff(i-i0,j-j0) * G%mask2dT(i,j) endif ! ice runoff flux - if (associated(IOB%rofi_flux)) then - fluxes%frunoff(i,j) = IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) - elseif (associated(IOB%calving)) then - fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%frunoff)) then + fluxes%frunoff(i,j) = IOB%frunoff(i-i0,j-j0) * G%mask2dT(i,j) endif if (associated(IOB%ustar_berg)) & @@ -447,11 +450,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (associated(IOB%mass_berg)) & fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) - if (associated(IOB%runoff_hflx)) & - fluxes%heat_content_lrunoff(i,j) = IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%lrunoff_hflx)) & + fluxes%heat_content_lrunoff(i,j) = IOB%lrunoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) - if (associated(IOB%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + if (associated(IOB%frunoff_hflx)) & + fluxes%heat_content_frunoff(i,j) = IOB%frunoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%lw_flux)) & fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) @@ -1262,7 +1265,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & "If true, allows flux adjustments to specified via the "//& "data_table using the component name 'OCN'.", default=.false.) - if (CS%allow_flux_adjustments) then + + call get_param(param_file, mdl, "LIQUID_RUNOFF_FROM_DATA", CS%liquid_runoff_from_data, & + "If true, allows liquid river runoff to be specified via the "//& + "data_table using the component name 'OCN'.", default=.false.) + + if (CS%allow_flux_adjustments .or. CS%liquid_runoff_from_data) then call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) endif @@ -1352,8 +1360,8 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) write(outunit,100) 'iobt%sw_flux_nir_dif' , mpp_chksum( iobt%sw_flux_nir_dif) write(outunit,100) 'iobt%lprec ' , mpp_chksum( iobt%lprec ) write(outunit,100) 'iobt%fprec ' , mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ' , mpp_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ' , mpp_chksum( iobt%calving ) + write(outunit,100) 'iobt%lrunoff ' , mpp_chksum( iobt%lrunoff ) + write(outunit,100) 'iobt%frunoff ' , mpp_chksum( iobt%frunoff ) write(outunit,100) 'iobt%p ' , mpp_chksum( iobt%p ) if (associated(iobt%ustar_berg)) & write(outunit,100) 'iobt%ustar_berg ' , mpp_chksum( iobt%ustar_berg ) From 64be85f767ee073eedffa207e5766013a6bdd7a6 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sun, 17 Nov 2019 13:30:03 +0000 Subject: [PATCH 059/137] minor text changes; uncomment runoff heat flux terms; required change made in feature/runoff_names branch of NEMS --- config_src/nuopc_driver/mom_cap.F90 | 16 +++++------ config_src/nuopc_driver/mom_cap_methods.F90 | 28 +++++++++---------- .../mom_surface_forcing_nuopc.F90 | 12 ++++---- 3 files changed, 27 insertions(+), 29 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 50df123264..5eb7f2493c 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -708,8 +708,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & Ice_ocean_boundary% mi (isc:iec,jsc:jec), & Ice_ocean_boundary% p (isc:iec,jsc:jec), & - !Ice_ocean_boundary% lrunoff_hflx (isc:iec,jsc:jec), & - !Ice_ocean_boundary% frunoff_hflx (isc:iec,jsc:jec), & + Ice_ocean_boundary% lrunoff_hflx (isc:iec,jsc:jec), & + Ice_ocean_boundary% frunoff_hflx (isc:iec,jsc:jec), & Ice_ocean_boundary% lrunoff (isc:iec,jsc:jec), & Ice_ocean_boundary% frunoff (isc:iec,jsc:jec)) @@ -729,8 +729,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%seaice_melt_heat= 0.0 Ice_ocean_boundary%mi = 0.0 Ice_ocean_boundary%p = 0.0 - !Ice_ocean_boundary%lrunoff_hflx = 0.0 - !Ice_ocean_boundary%frunoff_hflx = 0.0 + Ice_ocean_boundary%lrunoff_hflx = 0.0 + Ice_ocean_boundary%frunoff_hflx = 0.0 Ice_ocean_boundary%lrunoff = 0.0 Ice_ocean_boundary%frunoff = 0.0 @@ -776,9 +776,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fresh_water_to_ocean_rate", "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "net_heat_flx_to_ocn" , "will provide") - - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") + !Requires nuopc dictionary change + call fld_list_add(fldsToOcn_num, fldsToOcn, "liquid_runoff_heat_flx" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "frozen_runoff_heat_flx" , "will provide") !--------- export fields ------------- call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") @@ -1715,8 +1715,6 @@ subroutine ModelAdvance(gcomp, rc) file=__FILE__)) & return ! bail out - call ice_ocn_bnd_from_data(Ice_ocean_boundary, Time, Time_step_coupled) ! for runoff - !--------------- ! Update MOM6 !--------------- diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 9d1278f25d..f8e4ba9d68 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -238,22 +238,22 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, return ! bail out ! heat content of lrunoff - !ice_ocean_boundary%lrunoff_hflx(:,:) = 0._ESMF_KIND_R8 - !call state_getimport(importState, 'liquid_runoff_heat_flx', & - ! isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_hflx, rc=rc) - !if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out + ice_ocean_boundary%lrunoff_hflx(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'liquid_runoff_heat_flx', & + isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_hflx, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! heat content of frunoff - !ice_ocean_boundary%frunoff_hflx(:,:) = 0._ESMF_KIND_R8 - !call state_getimport(importState, 'frozen_runoff_heat_flx', & - ! isc, iec, jsc, jec, ice_ocean_boundary%frunoff_hflx, rc=rc) - !if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out + ice_ocean_boundary%frunoff_hflx(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'frozen_runoff_heat_flx', & + isc, iec, jsc, jec, ice_ocean_boundary%frunoff_hflx, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !---- ! salt flux from ice diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 4ad84b353c..af59d7d6ea 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -172,8 +172,8 @@ module MOM_surface_forcing_nuopc real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m/s] real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs[m2/m2] real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) - !real, pointer, dimension(:,:) :: lrunoff_hflx =>NULL() !< heat content of liquid runoff [W/m2] - !real, pointer, dimension(:,:) :: frunoff_hflx =>NULL() !< heat content of frozen runoff [W/m2] + real, pointer, dimension(:,:) :: lrunoff_hflx =>NULL() !< heat content of liquid runoff [W/m2] + real, pointer, dimension(:,:) :: frunoff_hflx =>NULL() !< heat content of frozen runoff [W/m2] real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere !< on ocean surface [Pa] real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice [kg/m2] @@ -413,7 +413,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! Check that liquid runoff has a place to go if (CS%liquid_runoff_from_data .and. .not. associated(IOB%lrunoff)) then call MOM_error(FATAL, "liquid runoff is being added via data_override but "// & - "there is no associated runoff in the IOB%") + "there is no associated runoff in the IOB") return end if @@ -475,9 +475,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion endif - if (associated(IOB%calving)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion + if (associated(IOB%frunoff)) then + fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%frunoff(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%frunoff(i-i0,j-j0)*CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor From 7f2b93e4cddbb044662e9eef3e3e355e6c025031 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 18 Nov 2019 10:22:07 -0700 Subject: [PATCH 060/137] 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 061/137] 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 062/137] 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 063/137] 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 b66eafe4e50a7067b607e85935e06a3af2ea06c2 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 20 Nov 2019 17:07:34 +0000 Subject: [PATCH 064/137] backs out change in standard name for liquid and frozen heat flux since this will require a change in the nuopc field_dictionary. The fields are not currently used. --- config_src/nuopc_driver/mom_cap.F90 | 6 +++--- config_src/nuopc_driver/mom_cap_methods.F90 | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 5eb7f2493c..9d923bf8a3 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -776,9 +776,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fresh_water_to_ocean_rate", "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "net_heat_flx_to_ocn" , "will provide") - !Requires nuopc dictionary change - call fld_list_add(fldsToOcn_num, fldsToOcn, "liquid_runoff_heat_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "frozen_runoff_heat_flx" , "will provide") + !These are not currently used and changing requires a nuopc dictionary change + !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") + !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") !--------- export fields ------------- call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index f8e4ba9d68..70915d0e95 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -239,7 +239,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! heat content of lrunoff ice_ocean_boundary%lrunoff_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'liquid_runoff_heat_flx', & + call state_getimport(importState, 'mean_runoff_heat_flx', & isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_hflx, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & @@ -248,7 +248,7 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! heat content of frunoff ice_ocean_boundary%frunoff_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'frozen_runoff_heat_flx', & + call state_getimport(importState, 'mean_calving_heat_flx', & isc, iec, jsc, jec, ice_ocean_boundary%frunoff_hflx, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & From 2c6bdf9256e1324b5c4c5eafcb94676e283e06c8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 20 Nov 2019 13:45:29 -0700 Subject: [PATCH 065/137] 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 066/137] 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 067/137] 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 068/137] 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 069/137] 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 070/137] 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 cb79e977f691d7be6084f48eb1e0de5dc72b7cbc Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 5 Dec 2019 14:43:16 -0500 Subject: [PATCH 071/137] add changes from old MOM6 repo in cmeps_integration branch that were (#10) added to cap at or before code sprint but add these changes without requiring ifdef CMEPS flags --- config_src/nuopc_driver/mom_cap.F90 | 40 +++++++++++++++++++++-------- 1 file changed, 30 insertions(+), 10 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 9d923bf8a3..5977189476 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -123,6 +123,7 @@ module MOM_cap_mod integer :: export_slice = 1 character(len=256) :: tmpstr logical :: write_diagnostics = .false. +logical :: overwrite_timeslice = .false. character(len=32) :: runtype !< run type integer :: logunit !< stdout logging unit number logical :: profile_memory = .true. @@ -278,6 +279,21 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) file=__FILE__)) & return + overwrite_timeslice = .false. + call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + if (isPresent .and. isSet) overwrite_timeslice=(trim(value)=="true") + write(logmsg,*) overwrite_timeslice + call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + profile_memory = .false. call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) @@ -741,7 +757,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) file=__FILE__)) & return ! bail out + 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") + 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") @@ -1488,13 +1510,11 @@ subroutine DataInitialize(gcomp, rc) ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr call get_ocean_grid(ocean_state, ocean_grid) - if (cesm_coupled) then - call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - endif + call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & @@ -1537,7 +1557,7 @@ subroutine DataInitialize(gcomp, rc) if(write_diagnostics) then call NUOPC_Write(exportState, fileNamePrefix='field_init_ocn_export_', & - timeslice=import_slice, relaxedFlag=.true., rc=rc) + overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & @@ -1691,7 +1711,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & - timeslice=import_slice, relaxedFlag=.true., rc=rc) + overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & @@ -1847,7 +1867,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & - timeslice=export_slice, relaxedFlag=.true., rc=rc) + overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & From 20d076b4dc25a84de24c178e24c5f20c01f05af2 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 6 Dec 2019 22:48:11 +0000 Subject: [PATCH 072/137] 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 073/137] 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 074/137] 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 075/137] 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 076/137] 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 077/137] 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 078/137] 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 079/137] 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 080/137] 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 081/137] 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 082/137] 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 083/137] 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 084/137] 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 085/137] 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 086/137] 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 087/137] 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 088/137] 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 089/137] 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 090/137] 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 091/137] 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 092/137] 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 093/137] 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 094/137] 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 095/137] 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 096/137] 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 097/137] 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 098/137] 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 099/137] 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 100/137] 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 101/137] 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 102/137] 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 103/137] 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 104/137] 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 105/137] 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 c46d97c8f4ec952552c6fec8c57e4c7d43550577 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 21 Mar 2020 10:36:50 -0400 Subject: [PATCH 106/137] +Rescaled ISS%area_shelf_h to [L2] Rescaled the dimensions of ISS%area_shelf_h to [L2], and renamed float_frac to ground_frac to better reflect the meaning of this variable. All answers are bitwise identical, but there are changes to the units of some arguments to public interfaces. --- src/ice_shelf/MOM_ice_shelf.F90 | 53 +++++++----- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 99 ++++++++++------------ src/ice_shelf/MOM_ice_shelf_initialize.F90 | 25 +++--- src/ice_shelf/MOM_ice_shelf_state.F90 | 2 +- src/ice_shelf/user_shelf_init.F90 | 10 +-- 5 files changed, 96 insertions(+), 93 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a0f54efb2d..e262d35c74 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -637,7 +637,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! mass flux [kg s-1], part of ISOMIP diags. mass_flux(:,:) = 0.0 - mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) + mass_flux(:,:) = ISS%water_flux(:,:) * US%L_to_m**2*ISS%area_shelf_h(:,:) if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) @@ -786,21 +786,21 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) do j=jsd,jed ; do I=isd,ied-1 forces%frac_shelf_u(I,j) = 0.0 if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%areaCu(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) / & - (US%L_to_m**2*G%areaT(i,j) + US%L_to_m**2*G%areaT(i+1,j))) + forces%frac_shelf_u(I,j) = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) / & + (G%areaT(i,j) + G%areaT(i+1,j)) enddo ; enddo do J=jsd,jed-1 ; do i=isd,ied forces%frac_shelf_v(i,J) = 0.0 if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%areaCv(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) / & - (US%L_to_m**2*G%areaT(i,j) + US%L_to_m**2*G%areaT(i,j+1))) + forces%frac_shelf_v(i,J) = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) / & + (G%areaT(i,j) + G%areaT(i,j+1)) enddo ; enddo call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) endif !### Consider working over a smaller array range. do j=jsd,jed ; do i=isd,ied - press_ice = (ISS%area_shelf_h(i,j) * US%m_to_L**2*G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) + press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) if (associated(forces%p_surf)) then if (.not.forces%accumulate_p_surf) forces%p_surf(i,j) = 0.0 forces%p_surf(i,j) = forces%p_surf(i,j) + press_ice @@ -852,7 +852,7 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) call MOM_error(FATAL,"add_shelf_pressure: Incompatible ocean and ice shelf grids.") do j=js,je ; do i=is,ie - press_ice = (CS%ISS%area_shelf_h(i,j) * US%m_to_L**2*G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) + press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) if (associated(fluxes%p_surf)) then if (.not.fluxes%accumulate_p_surf) fluxes%p_surf(i,j) = 0.0 fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + press_ice @@ -882,7 +882,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- - real :: asv1, asv2 !< and v-points [m2]. + real :: asv1, asv2 !< and v-points [L2 ~> m2]. real :: fraz !< refreezing rate [kg m-2 s-1] real :: mean_melt_flux !< spatial mean melt flux [kg s-1] or [kg m-2 s-1] at various points in the code. real :: sponge_area !< total area of sponge region [m2] @@ -894,7 +894,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask !! at at previous time (Time-dt) - real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [m2] + real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [L2 ~> m2] !! at at previous time (Time-dt) type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state @@ -951,7 +951,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then do j=jsd,jed ; do i=isd,ied if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) * US%m_to_L**2*G%IareaT(i,j) + fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) * G%IareaT(i,j) enddo ; enddo endif @@ -998,7 +998,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie frac_area = fluxes%frac_shelf_h(i,j) if (frac_area > 0.0) & - mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * ISS%area_shelf_h(i,j) + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%L_to_m**2*ISS%area_shelf_h(i,j) !### These hard-coded limits need to be corrected. They are inappropriate here. if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then @@ -1031,8 +1031,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! just floating shelf (0.1 is a threshold for min ocean thickness) if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then - shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * US%L_to_m**2*ISS%area_shelf_h(i,j)) + shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * US%L_to_m**2*ISS%area_shelf_h(i,j)) endif enddo ; enddo call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) @@ -1099,7 +1099,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a reastart fole to the internal representation in this run. + ! a restart file to the internal representation in this run. + real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in + ! a restart file to the internal representation in this run. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1328,7 +1330,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) TideAmp_file = trim(inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%utide,G%domain,timelevel=1) + call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, G%domain, timelevel=1) else call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & @@ -1421,6 +1423,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "ice sheet/shelf thickness", "m") call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & "Height unit conversion factor", "Z meter-1") + call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & + "Length unit conversion factor", "L meter-1") if (CS%active_shelf_dynamics) then call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & "ice sheet/shelf thickness mask" ,"none") @@ -1503,6 +1507,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl enddo ; enddo endif + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then + L_rescale = US%m_to_L / US%m_to_L_restart + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ISS%area_shelf_h(i,j) = L_rescale**2 * ISS%area_shelf_h(i,j) + enddo ; enddo + endif + endif ! .not. new_sim CS%Time = Time @@ -1516,13 +1527,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call cpu_clock_end(id_clock_pass) do j=jsd,jed ; do i=isd,ied - if (ISS%area_shelf_h(i,j) > US%L_to_m**2*G%areaT(i,j)) then + if (ISS%area_shelf_h(i,j) > G%areaT(i,j)) then call MOM_error(WARNING,"Initialize_ice_shelf: area_shelf_h exceeds G%areaT.") - ISS%area_shelf_h(i,j) = US%L_to_m**2*G%areaT(i,j) + ISS%area_shelf_h(i,j) = G%areaT(i,j) endif enddo ; enddo if (present(fluxes)) then ; do j=jsd,jed ; do i=isd,ied - if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) / (US%L_to_m**2*G%areaT(i,j)) + if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) / G%areaT(i,j) enddo ; enddo ; endif if (CS%debug) then @@ -1558,13 +1569,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_area_shelf_h = register_diag_field('ocean_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Area in cell', 'meter-2') + 'Ice Shelf Area in cell', 'meter-2', conversion=US%L_to_m**2) CS%id_shelf_mass = register_diag_field('ocean_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & 'mass of shelf', 'kg/m^2') CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_m) CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& - CS%Time,'Total mass flux of freshwater across the ice-ocean interface.', 'kg/s') + CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', 'kg/s') CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & 'Ice Shelf Melt Rate', 'm yr-1') CS%id_thermal_driving = register_diag_field('ocean_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & @@ -1695,7 +1706,7 @@ subroutine update_shelf_mass(G, CS, ISS, Time) ISS%area_shelf_h(i,j) = 0.0 ISS%hmask(i,j) = 0. if (ISS%mass_shelf(i,j) > 0.0) then - ISS%area_shelf_h(i,j) = G%US%L_to_m**2*G%areaT(i,j) + ISS%area_shelf_h(i,j) = G%areaT(i,j) ISS%h_shelf(i,j) = ISS%mass_shelf(i,j) / CS%rho_ice ISS%hmask(i,j) = 1. endif diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 928221d276..a55f19ad86 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -83,11 +83,11 @@ module MOM_ice_shelf_dynamics !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. - real, pointer, dimension(:,:) :: float_frac_rt => NULL() !< A running total for calculating float_frac. + real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. - real, pointer, dimension(:,:) :: float_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column - !! thickness is below a threshold. - !### [if float_frac = 1 ==> grounded; obviously counterintuitive; might fix] + real, pointer, dimension(:,:) :: ground_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column + !! thickness is below a threshold and interacting with the rock [nondim]. When this + !! is 1, the ice-shelf is grounded integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity @@ -149,7 +149,7 @@ module MOM_ice_shelf_dynamics !>@{ Diagnostic handles integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & - id_float_frac = -1, id_col_thick = -1, id_OD_av = -1, & + id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, & id_u_mask = -1, id_v_mask = -1, id_t_mask = -1 !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) @@ -237,7 +237,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 allocate( CS%taub_beta_eff(isd:ied,jsd:jed) ) ; CS%taub_beta_eff(:,:) = 0.0 allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 - allocate( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 + allocate( CS%ground_frac(isd:ied,jsd:jed) ) ; CS%ground_frac(:,:) = 0.0 ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & @@ -248,7 +248,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) "ice sheet/shelf vertically averaged temperature", "deg C") call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & "Average open ocean depth in a cell","m") - call register_restart_field(CS%float_frac, "float_frac", .true., restart_CS, & + call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & "Glens law ice viscosity", "m (seems wrong)") @@ -276,7 +276,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Local variables real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a reastart fole to the internal representation in this run. + ! a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" character(len=200) :: config @@ -420,7 +420,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%OD_rt_counter = 0 allocate( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 - allocate( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 + allocate( CS%ground_frac_rt(isd:ied,jsd:jed) ) ; CS%ground_frac_rt(:,:) = 0.0 if (CS%calve_to_mask) then allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 @@ -459,7 +459,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif call pass_var(CS%OD_av,G%domain) - call pass_var(CS%float_frac,G%domain) + call pass_var(CS%ground_frac,G%domain) call pass_var(CS%ice_visc,G%domain) call pass_var(CS%taub_beta_eff,G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) @@ -513,8 +513,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'mask for v-nodes', 'none') ! CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1, Time, & ! 'ice surf elev', 'm') - CS%id_float_frac = register_diag_field('ocean_model','ice_float_frac',CS%diag%axesT1, Time, & - 'fraction of cell that is floating (sort of)', 'none') + CS%id_ground_frac = register_diag_field('ocean_model','ice_ground_frac',CS%diag%axesT1, Time, & + 'fraction of cell that is grounded', 'none') CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1, Time, & @@ -558,10 +558,10 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD - CS%float_frac(i,j) = 0. + CS%ground_frac(i,j) = 0. else CS%OD_av(i,j) = 0. - CS%float_frac(i,j) = 1. + CS%ground_frac(i,j) = 1. endif enddo enddo @@ -651,7 +651,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) + if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) @@ -849,7 +849,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) enddo if ((nodefloat > 0) .and. (nodefloat < 4)) then float_cond(i,j) = 1.0 - CS%float_frac(i,j) = 1.0 + CS%ground_frac(i,j) = 1.0 endif enddo enddo @@ -891,7 +891,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_frac(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & @@ -948,7 +948,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_frac(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1896,7 +1896,9 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) integer :: i_off, j_off integer :: iter_flag - real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux + real :: h_reference, dxh, dyh, rho, tot_flux + real :: partial_vol ! The volume covered by ice shelf [m L2 ~> m3] + real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message integer, dimension(4) :: mapi, mapj, new_partial ! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace @@ -1957,9 +1959,9 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) enddo if (n_flux > 0) then - dxdyh = G%US%L_to_m**2*G%areaT(i,j) + dxdyh = G%areaT(i,j) h_reference = h_reference / real(n_flux) - partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux + partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + G%US%m_to_L**2*tot_flux if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow ISS%hmask(i,j) = 1 @@ -1967,7 +1969,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) ISS%area_shelf_h(i,j) = dxdyh elseif ((partial_vol / dxdyh) < h_reference) then ISS%hmask(i,j) = 2 - ! ISS%mass_shelf(i,j) = partial_vol * rho + ! ISS%mass_shelf(i,j) = G%US%L_to_m**2*partial_vol * rho ISS%area_shelf_h(i,j) = partial_vol / h_reference ISS%h_shelf(i,j) = h_reference else @@ -1988,8 +1990,6 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) n_flux = n_flux + 1 new_partial(k) = 1 endif - enddo - do k=1,2 if (CS%v_face_mask(i,j-2+k) == 2) then n_flux = n_flux + 1 elseif (ISS%hmask(i,j+2*k-3) == 0) then @@ -2005,11 +2005,9 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) do k=1,2 if (new_partial(k) == 1) & - flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) - enddo - do k=1,2 ! ### Combine these two loops? + flux_enter_replace(i+2*k-3,j,3-k) = G%US%L_to_m**2*partial_vol / real(n_flux) if (new_partial(k+2) == 1) & - flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) + flux_enter_replace(i,j+2*k-3,5-k) = G%US%L_to_m**2*partial_vol / real(n_flux) enddo endif @@ -2037,12 +2035,10 @@ end subroutine shelf_advance_front !> Apply a very simple calving law using a minimum thickness rule subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by + !! the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, intent(in) :: thickness_calve !< The thickness at which to trigger calving [Z ~> m]. @@ -2051,7 +2047,7 @@ subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickn do j=G%jsd,G%jed do i=G%isd,G%ied ! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & -! (CS%float_frac(i,j) == 0.0)) then +! (CS%ground_frac(i,j) == 0.0)) then if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then h_shelf(i,j) = 0.0 area_shelf_h(i,j) = 0.0 @@ -2064,16 +2060,13 @@ end subroutine ice_shelf_min_thickness_calve subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: calve_mask !< A mask that indicates where the ice shelf - !! can exist, and where it will calve. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by + !! the ice shelf [L2 ~> m2]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: calve_mask !< A mask that indicates where the ice + !! shelf can exist, and where it will calve. integer :: i,j @@ -2235,7 +2228,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) taud_x(I,J) = taud_x(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh taud_y(I,J) = taud_y(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh - if (CS%float_frac(i,j) == 1) then + if (CS%ground_frac(i,j) == 1) then neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) else neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 @@ -3066,7 +3059,7 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) do j=jsc,jec ; do i=isc,iec CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*I_rho_ocean if (ocean_mass(i,j)*I_rho_ocean > CS%thresh_float_col_depth) then - CS%float_frac_rt(i,j) = CS%float_frac_rt(i,j) + 1.0 + CS%ground_frac_rt(i,j) = CS%ground_frac_rt(i,j) + 1.0 endif enddo ; enddo CS%OD_rt_counter = CS%OD_rt_counter + 1 @@ -3074,13 +3067,13 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) if (find_avg) then I_counter = 1.0 / real(CS%OD_rt_counter) do j=jsc,jec ; do i=isc,iec - CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) * I_counter) + CS%ground_frac(i,j) = 1.0 - (CS%ground_frac_rt(i,j) * I_counter) CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter - CS%OD_rt(i,j) = 0.0 ; CS%float_frac_rt(i,j) = 0.0 + CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 enddo ; enddo - call pass_var(CS%float_frac, G%domain) + call pass_var(CS%ground_frac, G%domain) call pass_var(CS%OD_av, G%domain) endif @@ -3104,10 +3097,10 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD - CS%float_frac(i,j) = 0. + CS%ground_frac(i,j) = 0. else CS%OD_av(i,j) = 0. - CS%float_frac(i,j) = 1. + CS%ground_frac(i,j) = 1. endif enddo enddo @@ -3463,7 +3456,7 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%ice_visc, CS%taub_beta_eff) deallocate(CS%OD_rt, CS%OD_av) - deallocate(CS%float_frac, CS%float_frac_rt) + deallocate(CS%ground_frac, CS%ground_frac_rt) deallocate(CS) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 2ace1b2137..16eb923fd4 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -30,7 +30,7 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, PF) real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -60,9 +60,9 @@ end subroutine initialize_ice_thickness subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< The ice shelf thickness [m]. + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -70,7 +70,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! This subroutine reads ice thickness and area from a file and puts it into - ! h_shelf and area_shelf_h in m (and dimensionless) and updates hmask + ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask character(len=200) :: filename,thickness_file,inputdir ! Strings for file/path character(len=200) :: thickness_varname, area_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name. @@ -101,7 +101,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U " initialize_topography_from_file: Unable to open "//trim(filename)) call MOM_read_data(filename, trim(thickness_varname), h_shelf, G%Domain, scale=US%m_to_Z) - call MOM_read_data(filename,trim(area_varname),area_shelf_h,G%Domain) + call MOM_read_data(filename,trim(area_varname), area_shelf_h, G%Domain, scale=US%m_to_L**2) ! call get_param(PF, mdl, "ICE_BOUNDARY_CONFIG", config, & ! "This specifies how the ice domain boundary is specified", & @@ -120,7 +120,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U udh = exp(-(G%geoLonCv(i,j)-len_sidestress)/5.0) * h_shelf(i,j) if (udh <= 25.0) then h_shelf(i,j) = 0.0 - area_shelf_h (i,j) = 0.0 + area_shelf_h(i,j) = 0.0 else h_shelf(i,j) = udh endif @@ -128,11 +128,11 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U ! update thickness mask - if (area_shelf_h (i,j) >= US%L_to_m**2*G%areaT(i,j)) then + if (area_shelf_h (i,j) >= G%areaT(i,j)) then hmask(i,j) = 1. elseif (area_shelf_h (i,j) == 0.0) then hmask(i,j) = 0. - elseif ((area_shelf_h(i,j) > 0) .and. (area_shelf_h(i,j) <= US%L_to_m**2*G%areaT(i,j))) then + elseif ((area_shelf_h(i,j) > 0) .and. (area_shelf_h(i,j) <= G%areaT(i,j))) then hmask(i,j) = 2. else call MOM_error(FATAL,mdl// " AREA IN CELL OUT OF RANGE") @@ -140,7 +140,6 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U enddo enddo - end subroutine initialize_ice_thickness_from_file !> Initialize ice shelf thickness for a channel configuration @@ -149,7 +148,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -206,11 +205,11 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, h_shelf (i,j) = 0.0 else if (G%geoLonCu(i,j) > edge_pos) then - area_shelf_h(i,j) = US%L_to_m**2*G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & - (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) + area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & + (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) hmask (i,j) = 2.0 else - area_shelf_h(i,j) = US%L_to_m**2*G%areaT(i,j) + area_shelf_h(i,j) = G%areaT(i,j) hmask (i,j) = 1.0 endif diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 414a3389d6..91e9a41687 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -24,7 +24,7 @@ module MOM_ice_shelf_state type, public :: ice_shelf_state real, pointer, dimension(:,:) :: & mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [kg m-2]. - area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [m2]. + area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. h_shelf => NULL(), & !< the thickness of the shelf [m], redundant with mass but may !! make the code more readable hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index c0c7c96a59..100f8e652a 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -49,7 +49,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -105,7 +105,7 @@ subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, param_fi real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: h_shelf !< The ice shelf thickness [m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -128,7 +128,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C intent(inout) :: mass_shelf !< The ice shelf mass per unit area averaged !! over the full ocean cell [kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -168,11 +168,11 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C h_shelf (i,j) = 0.0 else if (G%geoLonCu(i,j) > edge_pos) then - area_shelf_h(i,j) = G%US%L_to_m**2*G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & + area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) hmask (i,j) = 2.0 else - area_shelf_h(i,j) = G%US%L_to_m**2*G%areaT(i,j) + area_shelf_h(i,j) = G%areaT(i,j) hmask (i,j) = 1.0 endif From 1160c6bd70900c9d5ad4cd2a9380741672002342 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 21 Mar 2020 14:37:08 -0400 Subject: [PATCH 107/137] +Rescaled forcing%ice_shelf_melt and ice_shelf variables Rescale the units of forcing%ice_shelf melt and added dimensional rescaling to various internal ice_shelf variables, including heat capacities, densities, latent heat coefficients and ISS%water_flux. Also canceled out common rescaling factors. All answers in the MOM6-examples test cases are bitwise identical, including the ISOMIP test case. --- src/core/MOM_forcing_type.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 130 ++++++++++++----------- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 19 ++-- src/ice_shelf/MOM_ice_shelf_state.F90 | 2 +- src/ice_shelf/MOM_marine_ice.F90 | 29 +++-- src/tracer/ISOMIP_tracer.F90 | 5 +- 6 files changed, 94 insertions(+), 93 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 167ae0581d..ebafa1d47a 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -149,7 +149,7 @@ module MOM_forcing_type !! associated if ice shelves are enabled, and are !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) - !! or freezing (negative) [m year-1] + !! or freezing (negative) [Z year-1 ~> m year-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index e262d35c74..5a7befbea7 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -91,20 +91,20 @@ module MOM_ice_shelf real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. real :: g_Earth !< The gravitational acceleration [m s-2] - real :: Cp !< The heat capacity of sea water [J kg-1 degC-1]. + real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. real :: Rho0 !< A reference ocean density [kg m-3]. - real :: Cp_ice !< The heat capacity of fresh ice [J kg-1 degC-1]. + real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the !< 2-equation formulation [m s-1]. real :: Salin_ice !< The salinity of shelf ice [ppt]. real :: Temp_ice !< The core temperature of shelf ice [degC]. real :: kv_ice !< The viscosity of ice [m2 s-1]. - real :: density_ice !< A typical density of ice [kg m-3]. + real :: density_ice !< A typical density of ice [R ~> kg m-3]. real :: rho_ice !< Nominal ice density [kg m-2 Z-1 ~> kg m-3]. real :: kv_molec !< The molecular kinematic viscosity of sea water [m2 s-1]. real :: kd_molec_salt!< The molecular diffusivity of salt [m2 s-1]. real :: kd_molec_temp!< The molecular diffusivity of heat [m2 s-1]. - real :: Lat_fusion !< The latent heat of fusion [J kg-1]. + real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. real :: col_thick_melt_threshold !< if the mixed layer is below this threshold, melt rate @@ -222,7 +222,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) exch_vel_s !< Sub-shelf salt exchange velocity [m s-1] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & - mass_flux !< total mass flux of freshwater across + mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg/s] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & haline_driving !< (SSS - S_boundary) ice-ocean !! interface, positive for melting and negative for freezing. @@ -232,7 +232,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! viscosity is linearly increasing. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N. - real :: LF, I_LF !< Latent Heat of fusion [J kg-1] and its inverse. + real :: LF !< Latent Heat of fusion [J kg-1]. + real :: I_LF !< The inverse of the latent Heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of VK. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. @@ -250,14 +251,15 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: wB_flux !< The vertical flux of heat just inside the ocean [m2 s-3]. real :: dB_dS !< The derivative of buoyancy with salinity [m s-2 ppt-1]. real :: dB_dT !< The derivative of buoyancy with temperature [m s-2 degC-1]. - real :: I_n_star, n_star_term, absf + real :: I_n_star, n_star_term + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in ???. real :: dT_ustar, dS_ustar - real :: ustar_h + real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] real :: Gam_turb real :: Gam_mol_t, Gam_mol_s - real :: RhoCp - real :: I_RhoLF + real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R ~> J m-3] +!### real :: I_RhoLF ! The inverse of the ocean density times the latent heat of fusion [Q-1 R-1 ~> m3 J-1] real :: ln_neut real :: mass_exch real :: Sb_min, Sb_max @@ -286,13 +288,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed I_ZETA_N = 1.0 / ZETA_N - LF = CS%Lat_fusion - I_RhoLF = 1.0/(CS%Rho0*LF) - I_LF = 1.0 / LF + LF = US%Q_to_J_kg*CS%Lat_fusion +!### I_RhoLF = 1.0/(CS%Rho0*US%Q_to_J_kg*CS%Lat_fusion) + I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK - RhoCp = CS%Rho0 * CS%Cp + RhoCp = US%kg_m3_to_R*CS%Rho0 * CS%Cp Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component @@ -369,23 +371,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s * & sqrt(CS%cdrag*((u_at_h**2 + v_at_h**2) + CS%utide(i,j)**1))) - ustar_h = US%Z_to_m*US%s_to_T*fluxes%ustar_shelf(i,j) + ustar_h = fluxes%ustar_shelf(i,j) ! I think that the following can be deleted without causing any problems. ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then ! ! These arrays are supposed to be stress components at C-grid points, which is ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = ustar_h*ustar_h*CS%Rho0*Isqrt2 + ! state%taux_shelf(i,j) = US%Z_to_m**2*US%s_to_T**2*ustar_h**2 * CS%Rho0*Isqrt2 ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) ! endif ! Estimate the neutral ocean boundary layer thickness as the minimum of the ! reported ocean mixed layer thickness and the neutral Ekman depth. - absf = 0.25*US%s_to_T*((abs(US%s_to_T*G%CoriolisBu(I,J)) + abs(US%s_to_T*G%CoriolisBu(I-1,J-1))) + & - (abs(US%s_to_T*G%CoriolisBu(I,J-1)) + abs(US%s_to_T*G%CoriolisBu(I-1,J)))) - if (absf*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = state%Hml(i,j) - else ; hBL_neut = (VK*ustar_h) / absf ; endif - hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%Kv_molec)) + absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + if (absf*US%Z_to_m*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = state%Hml(i,j) + else ; hBL_neut = US%Z_to_m*(VK*ustar_h) / absf ; endif + hBL_neut_h_molec = ZETA_N * ((hBL_neut * US%Z_to_m*US%s_to_T*ustar_h) / (5.0 * CS%Kv_molec)) ! Determine the mixed layer buoyancy flux, wB_flux. dB_dS = (CS%g_Earth / Rhoml(i)) * dR0_dS(i) @@ -395,11 +397,11 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%find_salt_root) then ! read liquidus parameters - S_a = CS%lambda1 * CS%Gamma_T_3EQ * CS%Cp + S_a = CS%lambda1 * CS%Gamma_T_3EQ * US%Q_to_J_kg*CS%Cp ! S_b = -CS%Gamma_T_3EQ*(CS%lambda2-CS%lambda3*p_int(i)-state%sst(i,j)) & ! -LF*CS%Gamma_T_3EQ/35.0 - S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%lambda2+CS%lambda3*p_int(i)- & + S_b = CS%Gamma_T_3EQ*US%Q_to_J_kg*CS%Cp*(CS%lambda2+CS%lambda3*p_int(i)- & state%sst(i,j))-LF*CS%Gamma_T_3EQ/35.0 S_c = LF*(CS%Gamma_T_3EQ/35.0)*state%sss(i,j) @@ -425,8 +427,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Determine the potential temperature at the ice-ocean interface. call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h - dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h + dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * US%Z_to_m*US%s_to_T*ustar_h + dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * US%Z_to_m*US%s_to_T*ustar_h ! First, determine the buoyancy flux assuming no effects of stability ! on the turbulence. Following H & J '99, this limit also applies @@ -448,7 +450,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (wB_flux > 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent ! fluxes, and iteration is required. - n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / ustar_h**3 + n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (US%Z_to_m*US%s_to_T*ustar_h)**3 do it3 = 1,30 ! n_star <= 1.0 is the ratio of working boundary layer thickness ! to the neutral thickness. @@ -492,9 +494,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo !it3 endif - ISS%tflux_ocn(i,j) = RhoCp * wT_flux - exch_vel_t(i,j) = ustar_h * I_Gam_T - exch_vel_s(i,j) = ustar_h * I_Gam_S + ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * wT_flux + exch_vel_t(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_T + exch_vel_s(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_S !Calculate the heat flux inside the ice shelf. @@ -505,23 +507,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !If this approximation is not made, iterations are required... See H+J Fig 3. if (ISS%tflux_ocn(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. - ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) + ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) ISS%tflux_shelf(i,j) = 0.0 else if (CS%insulator) then !no conduction/perfect insulator ISS%tflux_shelf(i,j) = 0.0 - ISS%water_flux(i,j) = I_LF * (- ISS%tflux_shelf(i,j) + ISS%tflux_ocn(i,j)) + ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * (- ISS%tflux_shelf(i,j) + ISS%tflux_ocn(i,j)) else ! With melting, from H&J 1999, eqs (31) & (26)... ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec ! RhoLF*lprec = Q_ice + ISS%tflux_ocn(i,j) ! lprec = (ISS%tflux_ocn(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) - ISS%water_flux(i,j) = ISS%tflux_ocn(i,j) / & + ISS%water_flux(i,j) = US%kg_m2s_to_RZ_T * ISS%tflux_ocn(i,j) / & (LF + CS%CP_Ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) - ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*ISS%water_flux(i,j) + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) endif endif @@ -535,8 +537,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else mass_exch = exch_vel_s(i,j) * CS%Rho0 - Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * & - ISS%water_flux(i,j)) / (mass_exch + ISS%water_flux(i,j)) + Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * US%RZ_T_to_kg_m2s*ISS%water_flux(i,j)) / & + (mass_exch + US%RZ_T_to_kg_m2s*ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) if (abs(dS_it) < 1e-4*(0.5*(state%sss(i,j) + Sbdry(i,j) + 1.e-10))) exit @@ -574,9 +576,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) exch_vel_t(i,j) = CS%gamma_t - ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) ISS%tflux_shelf(i,j) = 0.0 - ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) + ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif else !not shelf @@ -588,12 +590,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo ! i-loop enddo ! j-loop - ! ISS%water_flux = net liquid water into the ocean ( kg/(m^2 s) ) + ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] ! We want melt in m/year if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/rho_fw) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/rho_fw) * CS%flux_factor else ! use original eq. - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/CS%density_ice) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/CS%density_ice) * CS%flux_factor endif do j=js,je ; do i=is,ie @@ -610,7 +612,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%iceshelf_melt(i,j) = 0.0 endif ! Compute haline driving, which is one of the diags. used in ISOMIP - haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / & + haline_driving(i,j) = (US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * Sbdry(i,j)) / & (CS%Rho0 * exch_vel_s(i,j)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! @@ -637,7 +639,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! mass flux [kg s-1], part of ISOMIP diags. mass_flux(:,:) = 0.0 - mass_flux(:,:) = ISS%water_flux(:,:) * US%L_to_m**2*ISS%area_shelf_h(:,:) + mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) @@ -727,8 +729,8 @@ subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - if (ISS%water_flux(i,j) / rho_ice * time_step < ISS%h_shelf(i,j)) then - ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(i,j) / rho_ice * time_step + if (G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice else ! the ice is about to melt away, so set thickness, area, and mask to zero ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell @@ -815,7 +817,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! that it may have been zeroed out where IOB is translated to forces and ! contributions from icebergs and the sea-ice pack added subsequently. !### THE RIGIDITY SHOULD ALSO INCORPORATE AREAL-COVERAGE INFORMATION. - kv_rho_ice = CS%kv_ice / CS%density_ice + kv_rho_ice = CS%kv_ice / (US%R_to_kg_m3*CS%density_ice) do j=js,je ; do I=is-1,ie if (.not.forces%accumulate_rigidity) forces%rigidity_ice_u(I,j) = 0.0 forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & @@ -900,7 +902,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) !! the ice-shelf state real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1] - real, parameter :: rho_fw = 1000.0 ! fresh water density + real :: rho_fw = 1000.0 ! Fresh water density [R ~> kg m-3] character(len=160) :: mesg ! The text of an error message integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -912,6 +914,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ISS => CS%ISS + rho_fw = 1000.0*US%kg_m3_to_R ! fresh water density + call add_shelf_pressure(G, US, CS, fluxes) ! Determine ustar and the square magnitude of the velocity in the @@ -967,10 +971,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 if (associated(fluxes%lprec)) then if (ISS%water_flux(i,j) > 0.0) then - fluxes%lprec(i,j) = US%kg_m2s_to_RZ_T*frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%lprec(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor else fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = US%kg_m2s_to_RZ_T*frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor endif endif @@ -998,7 +1002,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie frac_area = fluxes%frac_shelf_h(i,j) if (frac_area > 0.0) & - mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%L_to_m**2*ISS%area_shelf_h(i,j) + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%RZ_T_to_kg_m2s*US%L_to_m**2*ISS%area_shelf_h(i,j) !### These hard-coded limits need to be corrected. They are inappropriate here. if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then @@ -1037,9 +1041,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) enddo ; enddo call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step -! delta_mass_shelf = (shelf_mass1 - shelf_mass0)* & -! (rho_fw/CS%density_ice)/CS%time_step -! write(mesg,*)'delta_mass_shelf = ',delta_mass_shelf +! delta_mass_shelf = (shelf_mass1 - shelf_mass0) * (rho_fw/(CS%density_ice*CS%time_step)) +! write(mesg,*) 'delta_mass_shelf = ', delta_mass_shelf ! call MOM_mesg(mesg,5) else! first time step delta_mass_shelf = 0.0 @@ -1058,10 +1061,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie ! Note the following is hard coded for ISOMIP if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative + fluxes%vprec(i,j) = -mean_melt_flux * US%R_to_kg_m3*CS%density_ice/1000. ! evap is negative ! Rescale fluxes%vprec to the proper units. fluxes%vprec(i,j) = US%kg_m2s_to_RZ_T * fluxes%vprec(i,j) - fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] + fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*US%Q_to_J_kg*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) endif enddo ; enddo @@ -1170,7 +1173,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB - CS%Lat_fusion = 3.34e5 + CS%Lat_fusion = 3.34e5*US%J_kg_to_Q CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. call log_version(param_file, mdl, version, "") @@ -1271,7 +1274,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "C_P", CS%Cp, & - "The heat capacity of sea water.", units="J kg-1 K-1", & + "The heat capacity of sea water.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & fail_if_missing=.true.) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& @@ -1280,7 +1283,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & - "The heat capacity of ice.", units="J kg-1 K-1", & + "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & @@ -1345,7 +1348,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%active_shelf_dynamics) then call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & - "A typical density of ice.", units="kg m-3", default=917.0) + "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & "volume flux at upstream boundary", units="m2 s-1", default=0.) @@ -1354,9 +1357,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl else ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & - "A typical density of ice.", units="kg m-3", default=900.0) + "A typical density of ice.", units="kg m-3", default=900.0, scale=US%kg_m3_to_R) endif - CS%rho_ice = CS%density_ice*US%Z_to_m + CS%rho_ice = CS%density_ice*US%Z_to_m*US%R_to_kg_m3 call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & "Min thickness rule for the very simple calving law",& @@ -1439,8 +1442,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl !if (.not. CS%solo_ice_sheet) then ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & ! "Friction velocity under ice shelves", "m s-1") - ! call register_restart_field(fluxes%iceshelf_melt, "iceshelf_melt", .false., CS%restart_CSp, & - ! "Ice Shelf Melt Rate", "m year-1") !endif CS%restart_output_dir = dirs%restart_output_dir @@ -1575,9 +1576,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_m) CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& - CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', 'kg/s') + CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', & + 'kg/s', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Melt Rate', 'm yr-1') + 'Ice Shelf Melt Rate', 'm yr-1', conversion=US%Z_to_m) CS%id_thermal_driving = register_diag_field('ocean_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') CS%id_haline_driving = register_diag_field('ocean_model', 'haline_driving', CS%diag%axesT1, CS%Time, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index a55f19ad86..cf82092dc5 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -3472,7 +3472,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors real, intent(in) :: time_step !< The time step for this update [s]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: melt_rate !< basal melt rate [kg m-2 s-1] + intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] type(time_type), intent(in) :: Time !< The current model time ! 5/23/12 OVS @@ -3507,12 +3507,15 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy, t_bd, Tsurf, adot + real :: rho, t_bd, Tsurf + real :: spy ! The amount of time in a year [T ~> s] + real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + spy = 365. * 86400. * US%s_to_T - adot = 0.1*US%m_to_Z/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + adot = 0.1*US%m_to_Z / spy Tsurf = -20.0 isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3546,8 +3549,8 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) - call ice_shelf_advect_temp_x(CS, G, time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, G, time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + call ice_shelf_advect_temp_x(CS, G, US%s_to_T*time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, US%s_to_T*time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) do j=jsd,jed do i=isd,ied @@ -3576,9 +3579,9 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then if (ISS%h_shelf(i,j) > 0.0) then ! CS%t_shelf(i,j) = CS%t_shelf(i,j) + & -! time_step*(adot*Tsurf - US%m_to_Z*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) +! US%s_to_T*time_step*(adot*Tsurf - US%R_to_kg_m3*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) CS%t_shelf(i,j) = CS%t_shelf(i,j) + & - time_step*(adot*Tsurf - (3.0*US%m_to_Z/spy)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) + US%s_to_T*time_step*(adot*Tsurf - (3.0*US%m_to_Z/spy)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) else ! the ice is about to melt away ! in this case set thickness, area, and mask to zero diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 91e9a41687..ac34817482 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -42,7 +42,7 @@ module MOM_ice_shelf_state salt_flux => NULL(), & !< The downward salt flux at the ocean-ice !! interface [kg m-2 s-1]. water_flux => NULL(), & !< The net downward liquid water flux at the - !! ocean-ice interface [kg m-2 s-1]. + !! ocean-ice interface [R Z T-1 ~> kg m-2 s-1]. tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice !! shelf at the ice-ocean interface [W m-2]. diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 4e3ce7401e..780cc8c3cd 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -30,7 +30,7 @@ module MOM_marine_ice real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy !! so that fluxes below are set to zero. (0.5 is a !! good value to use.) Not applied for negative values. - real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] + real :: latent_heat_fusion !< Latent heat of fusion [Q ~> J kg-1] real :: density_iceberg !< A typical density of icebergs [kg m-3] (for ice rigidity) type(time_type), pointer :: Time !< A pointer to the ocean model's clock. @@ -42,8 +42,7 @@ module MOM_marine_ice !> add_berg_flux_to_shelf adds rigidity and ice-area coverage due to icebergs !! to the forces type fields, and adds ice-areal coverage and modifies various !! thermodynamic fluxes due to the presence of icebergs. -subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, & - time_step, CS) +subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(surface), intent(inout) :: sfc_state !< A structure containing fields that @@ -81,18 +80,16 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, & do j=js,je ; do I=is-1,ie if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + & - (((forces%area_berg(i,j)*G%US%L_to_m**2*G%areaT(i,j)) + & - (forces%area_berg(i+1,j)*G%US%L_to_m**2*G%areaT(i+1,j))) / & - (G%US%L_to_m**2*G%areaT(i,j) + G%US%L_to_m**2*G%areaT(i+1,j)) ) + (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i+1,j)*G%areaT(i+1,j)) / & + (G%areaT(i,j) + G%areaT(i+1,j)) forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + kv_rho_ice * & min(forces%mass_berg(i,j), forces%mass_berg(i+1,j)) enddo ; enddo do J=js-1,je ; do i=is,ie if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + & - (((forces%area_berg(i,j)*G%US%L_to_m**2*G%areaT(i,j)) + & - (forces%area_berg(i,j+1)*G%US%L_to_m**2*G%areaT(i,j+1))) / & - (G%US%L_to_m**2*G%areaT(i,j) + G%US%L_to_m**2*G%areaT(i,j+1)) ) + (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i,j+1)*G%areaT(i,j+1)) / & + (G%areaT(i,j) + G%areaT(i,j+1)) forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + kv_rho_ice * & min(forces%mass_berg(i,j), forces%mass_berg(i,j+1)) enddo ; enddo @@ -101,8 +98,7 @@ end subroutine iceberg_forces !> iceberg_fluxes adds ice-area-coverage and modifies various !! thermodynamic fluxes due to the presence of icebergs. -subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & - time_step, CS) +subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, @@ -114,7 +110,8 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1] - real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [kg J-1 T-1 ~> kg J-1 s-1]. + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion times unit conversion + ! factors because sfc_state is in MKS units [R Z m2 J-1 T-1 ~> kg J-1 s-1]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed @@ -142,7 +139,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & !Zero'ing out other fluxes under the tabular icebergs if (CS%berg_area_threshold >= 0.) then - I_dt_LHF = 1.0 / (US%s_to_T*time_step * CS%latent_heat_fusion) + I_dt_LHF = US%W_m2_to_QRZ_T / (time_step * CS%latent_heat_fusion) do j=jsd,jed ; do i=isd,ied if (fluxes%frac_shelf_h(i,j) > CS%berg_area_threshold) then ! Only applying for ice shelf covering most of cell. @@ -157,7 +154,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & ! control structure for diagnostic purposes. if (allocated(sfc_state%frazil)) then - fraz = US%kg_m3_to_R*US%m_to_Z*sfc_state%frazil(i,j) * I_dt_LHF + fraz = sfc_state%frazil(i,j) * I_dt_LHF if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz ! if (associated(fluxes%lprec)) fluxes%lprec(i,j) = fluxes%lprec(i,j) - fraz sfc_state%frazil(i,j) = 0.0 @@ -193,11 +190,11 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) call log_version(mdl, version) call get_param(param_file, mdl, "KV_ICEBERG", CS%kv_iceberg, & - "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) + "The viscosity of the icebergs", units="m2 s-1", default=1.0e10) call get_param(param_file, mdl, "DENSITY_ICEBERGS", CS%density_iceberg, & "A typical density of icebergs.", units="kg m-3", default=917.0) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) + "The latent heat of fusion.", units="J/kg", default=hlf, scale=G%US%J_kg_to_Q) call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & "Fraction of grid cell which iceberg must occupy, so that fluxes "//& "below berg are set to zero. Not applied for negative "//& diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index c2b189917c..a711437191 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -276,12 +276,11 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real :: mmax real :: b1(SZI_(G)) ! b1 and c1 are variables used by the real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified - real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting - ! negative for freezing) + real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [Z year-1 ~> m year-1] + real :: mmax ! The global maximum melting rate [Z year-1 ~> m year-1] character(len=256) :: mesg ! The text of an error message integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke From 16a48e5c8f9b8b7a5e5e3774577ebf25fcdbc96b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 22 Mar 2020 09:12:32 -0400 Subject: [PATCH 108/137] Rescaled internal MOM_ice_shelf variables units Enabled the dimensional rescaling of the units of many internal variables in MOM_ice_shelf.F90, and added comments describing the units of other variables. Comments also highlight (but deliberately do not correct) several bugs in the 3-equation boundary property calculation. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 223 ++++++++++++++++---------------- 1 file changed, 114 insertions(+), 109 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5a7befbea7..45ded4de39 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -90,20 +90,20 @@ module MOM_ice_shelf real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. - real :: g_Earth !< The gravitational acceleration [m s-2] + real :: g_Earth !< The gravitational acceleration [Z T-2 ~> m s-2] real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. - real :: Rho0 !< A reference ocean density [kg m-3]. + real :: Rho0 !< A reference ocean density [R ~> kg m-3]. real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the - !< 2-equation formulation [m s-1]. + !< 2-equation formulation [Z T-1 ~> m s-1]. real :: Salin_ice !< The salinity of shelf ice [ppt]. real :: Temp_ice !< The core temperature of shelf ice [degC]. - real :: kv_ice !< The viscosity of ice [m2 s-1]. + real :: kv_ice !< The viscosity of ice [Z2 T-1 ~> m2 s-1]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. real :: rho_ice !< Nominal ice density [kg m-2 Z-1 ~> kg m-3]. - real :: kv_molec !< The molecular kinematic viscosity of sea water [m2 s-1]. - real :: kd_molec_salt!< The molecular diffusivity of salt [m2 s-1]. - real :: kd_molec_temp!< The molecular diffusivity of heat [m2 s-1]. + real :: kv_molec !< The molecular kinematic viscosity of sea water [Z2 T-1 ~> m2 s-1]. + real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1]. + real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. @@ -153,10 +153,11 @@ module MOM_ice_shelf logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. - real :: cutoff_depth !< depth above which melt is set to zero (>= 0). - real :: lambda1 !< liquidus coeff., Needed if find_salt_root = true - real :: lambda2 !< liquidus coeff., Needed if find_salt_root = true - real :: lambda3 !< liquidus coeff., Needed if find_salt_root = true + real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. + ! The following parameters are needed if find_salt_root = true + real :: lambda1 !< liquidus coeff. The freezing point at 0 pressure and 0 salinity [degC] + real :: lambda2 !< Partial derivative of freezing temperature with salinity [degC ppt-1] + real :: lambda3 !< Partial derivative of freezing temperature with pressure [degC Pa-1] !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -218,8 +219,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) p_int !< The pressure at the ice-ocean interface [Pa]. real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & - exch_vel_t, & !< Sub-shelf thermal exchange velocity [m s-1] - exch_vel_s !< Sub-shelf salt exchange velocity [m s-1] + exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] + exch_vel_s !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg/s] @@ -229,10 +230,10 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! This is computed as part of the ISOMIP diagnostics. real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless real :: ZETA_N = 0.052 !> The fraction of the boundary layer over which the - !! viscosity is linearly increasing. (Was 1/8. Why?) + !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. - real :: I_ZETA_N !< The inverse of ZETA_N. - real :: LF !< Latent Heat of fusion [J kg-1]. + real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. +!### real :: LF !< Latent Heat of fusion [J kg-1]. real :: I_LF !< The inverse of the latent Heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of VK. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. @@ -241,33 +242,37 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & Sbdry !< Salinities in the ocean at the interface with the ice shelf [ppt]. real :: Sbdry_it - real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! use to find salt roots + real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! Variables used to find salt roots real :: dS_it !< The interface salinity change during an iteration [ppt]. - real :: hBL_neut !< The neutral boundary layer thickness [m]. + real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness !! to the molecular boundary layer thickness [nondim]. !### THESE ARE CURRENTLY POSITIVE UPWARD. - real :: wT_flux !< The vertical flux of heat just inside the ocean [degC m s-1]. - real :: wB_flux !< The vertical flux of heat just inside the ocean [m2 s-3]. - real :: dB_dS !< The derivative of buoyancy with salinity [m s-2 ppt-1]. - real :: dB_dT !< The derivative of buoyancy with temperature [m s-2 degC-1]. - real :: I_n_star, n_star_term - real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] - real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in ???. - real :: dT_ustar, dS_ustar - real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] - real :: Gam_turb + real :: wT_flux !< The vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. + real :: wB_flux !< The vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. + real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. + real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 degC-1 ~> m s-2 degC-1]. + real :: I_n_star ! [nondim] + real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2] + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] + real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2] + real :: dT_ustar ! The difference between the ocean boundary layer temperature and the freezing + ! freezing point times the friction velocity [degC Z T-1 ~> degC m s-1] + real :: dS_ustar ! The difference between the ocean boundary layer salinity and the salinity + ! at the ice-ocean interface the friction velocity [ppt Z T-1 ~> ppt m s-1] + real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] + real :: Gam_turb ! [nondim] real :: Gam_mol_t, Gam_mol_s real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R ~> J m-3] -!### real :: I_RhoLF ! The inverse of the ocean density times the latent heat of fusion [Q-1 R-1 ~> m3 J-1] real :: ln_neut - real :: mass_exch + real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1] real :: Sb_min, Sb_max real :: dS_min, dS_max ! Variables used in iterating for wB_flux. - real :: wB_flux_new, DwB, dDwB_dwB_in - real :: I_Gam_T, I_Gam_S, dG_dwB, iDens - real :: u_at_h, v_at_h, Isqrt2 + real :: wB_flux_new, dDwB_dwB_in + real :: I_Gam_T, I_Gam_S, iDens + real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] + real :: Isqrt2 logical :: Sb_min_set, Sb_max_set logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true, the grouding line position is determined based on @@ -288,13 +293,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed I_ZETA_N = 1.0 / ZETA_N - LF = US%Q_to_J_kg*CS%Lat_fusion -!### I_RhoLF = 1.0/(CS%Rho0*US%Q_to_J_kg*CS%Lat_fusion) +!### LF = US%Q_to_J_kg*CS%Lat_fusion I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK - RhoCp = US%kg_m3_to_R*CS%Rho0 * CS%Cp + RhoCp = CS%Rho0 * CS%Cp Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component @@ -336,7 +340,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. - do i=is,ie ; p_int(i) = CS%g_Earth * ISS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = US%Z_to_m*US%s_to_T**2*CS%g_Earth * ISS%mass_shelf(i,j) ; enddo ! Calculate insitu densities and expansion coefficients call calculate_density(state%sst(:,j), state%sss(:,j), p_int, & @@ -360,16 +364,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Iteratively determine a self-consistent set of fluxes, with the ocean ! salinity just below the ice-shelf as the variable that is being ! iterated for. - ! ### SHOULD I SET USTAR_SHELF YET? - - u_at_h = state%u(i,j) - v_at_h = state%v(i,j) + ! ### SHOULD USTAR_SHELF BE SET YET? !### I think that CS%utide**1 should be CS%utide**2 ! Also I think that if taux_shelf and tauy_shelf have been calculated by the ! ocean stress calculation, they should be used here or later to set ustar_shelf. - RWH fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s * & - sqrt(CS%cdrag*((u_at_h**2 + v_at_h**2) + CS%utide(i,j)**1))) + sqrt(CS%cdrag*((state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**1))) ustar_h = fluxes%ustar_shelf(i,j) @@ -377,7 +378,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then ! ! These arrays are supposed to be stress components at C-grid points, which is ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = US%Z_to_m**2*US%s_to_T**2*ustar_h**2 * CS%Rho0*Isqrt2 + ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho0*Isqrt2 ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) ! endif @@ -385,9 +386,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! reported ocean mixed layer thickness and the neutral Ekman depth. absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) - if (absf*US%Z_to_m*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = state%Hml(i,j) - else ; hBL_neut = US%Z_to_m*(VK*ustar_h) / absf ; endif - hBL_neut_h_molec = ZETA_N * ((hBL_neut * US%Z_to_m*US%s_to_T*ustar_h) / (5.0 * CS%Kv_molec)) + if (absf*US%m_to_Z*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = US%m_to_Z*state%Hml(i,j) + else ; hBL_neut = (VK*ustar_h) / absf ; endif + hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec)) ! Determine the mixed layer buoyancy flux, wB_flux. dB_dS = (CS%g_Earth / Rhoml(i)) * dR0_dS(i) @@ -397,17 +398,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%find_salt_root) then ! read liquidus parameters - S_a = CS%lambda1 * CS%Gamma_T_3EQ * US%Q_to_J_kg*CS%Cp -! S_b = -CS%Gamma_T_3EQ*(CS%lambda2-CS%lambda3*p_int(i)-state%sst(i,j)) & -! -LF*CS%Gamma_T_3EQ/35.0 - - S_b = CS%Gamma_T_3EQ*US%Q_to_J_kg*CS%Cp*(CS%lambda2+CS%lambda3*p_int(i)- & - state%sst(i,j))-LF*CS%Gamma_T_3EQ/35.0 - S_c = LF*(CS%Gamma_T_3EQ/35.0)*state%sss(i,j) + !### This should be CS%lamda2! + S_a = CS%lambda1 * CS%Gamma_T_3EQ * CS%Cp + ! The value of 35.0 here should be a parameter? + !### This should be (CS%lambda1 + CS%lambda3*p_int(i) - state%sst(i,j)) + S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%lambda2 + CS%lambda3*p_int(i)- state%sst(i,j)) - & + CS%Lat_fusion * CS%Gamma_T_3EQ/35.0 + S_c = CS%Lat_fusion * (CS%Gamma_T_3EQ/35.0) * state%sss(i,j) !### Depending on the sign of S_b, one of these will be inaccurate! - Sbdry1 = (-S_b + SQRT(S_b*S_b-4*S_a*S_c))/(2*S_a) - Sbdry2 = (-S_b - SQRT(S_b*S_b-4*S_a*S_c))/(2*S_a) + ! if (S_b >= 0.0) then + Sbdry1 = (-S_b + SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) + ! Sbdry1 = 2*S_c / (S_b + SQRT(S_b*S_b - 4*S_a*S_c)) + Sbdry2 = (-S_b - SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) + ! else + ! Sbdry1 = (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) / (2.*S_a) + ! Sbdry2 = -2.*S_c / (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) + ! endif Sbdry(i,j) = MAX(Sbdry1, Sbdry2) ! Safety check if (Sbdry(i,j) < 0.) then @@ -427,8 +434,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Determine the potential temperature at the ice-ocean interface. call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * US%Z_to_m*US%s_to_T*ustar_h - dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * US%Z_to_m*US%s_to_T*ustar_h + dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h + dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h ! First, determine the buoyancy flux assuming no effects of stability ! on the turbulence. Following H & J '99, this limit also applies @@ -445,12 +452,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif wT_flux = dT_ustar * I_Gam_T - wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux + wB_flux = dB_dS * (dS_ustar * I_Gam_S) + US%Z_to_m*US%s_to_T**2*dB_dT * wT_flux if (wB_flux > 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent ! fluxes, and iteration is required. - n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (US%Z_to_m*US%s_to_T*ustar_h)**3 + n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 do it3 = 1,30 ! n_star <= 1.0 is the ratio of working boundary layer thickness ! to the neutral thickness. @@ -481,8 +488,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wT_flux = dT_ustar * I_Gam_T wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - ! Find the root where dwB = 0.0 - DwB = wB_flux_new - wB_flux + ! Find the root where wB_flux_new = wB_flux. if (abs(wB_flux_new - wB_flux) < & 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit @@ -490,18 +496,18 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. ! ### SHOULD BOUNDS BE NEEDED? - wB_flux_new = wB_flux - DwB / dDwB_dwB_in + wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif - ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * wT_flux - exch_vel_t(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_T - exch_vel_s(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_S + ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * US%Z_to_m*US%s_to_T*wT_flux + exch_vel_t(i,j) = ustar_h * I_Gam_T + exch_vel_s(i,j) = ustar_h * I_Gam_S !Calculate the heat flux inside the ice shelf. !vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). - ! Q_ice = rho_ice * CS%CP_Ice * K_ice * dT/dz (at interface) + ! Q_ice = rho_ice * CS%Cp_ice * K_ice * dT/dz (at interface) !vertical adv/diff as in H+J 199, eqs (31) & (26)... ! dT/dz ~= min( (lprec/(rho_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) !If this approximation is not made, iterations are required... See H+J Fig 3. @@ -517,19 +523,19 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else ! With melting, from H&J 1999, eqs (31) & (26)... - ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec + ! Q_ice ~= Cp_ice * (CS%Temp_Ice-T_freeze) * lprec ! RhoLF*lprec = Q_ice + ISS%tflux_ocn(i,j) - ! lprec = (ISS%tflux_ocn(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) - ISS%water_flux(i,j) = US%kg_m2s_to_RZ_T * ISS%tflux_ocn(i,j) / & - (LF + CS%CP_Ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + ! lprec = (ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * ISS%tflux_ocn(i,j) / & + (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) - ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - CS%Lat_fusion*US%QRZ_T_to_W_m2*ISS%water_flux(i,j) endif endif !other options: dTi/dz linear through shelf ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j))/G%draft(i,j) - ! ISS%tflux_shelf(i,j) = - Rho_Ice * CS%CP_Ice * KTI * dTi_dz + ! ISS%tflux_shelf(i,j) = - Rho_Ice * US%Q_to_J_kg*CS%Cp_ice * KTI * dTi_dz if (CS%find_salt_root) then @@ -537,8 +543,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else mass_exch = exch_vel_s(i,j) * CS%Rho0 - Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * US%RZ_T_to_kg_m2s*ISS%water_flux(i,j)) / & - (mass_exch + US%RZ_T_to_kg_m2s*ISS%water_flux(i,j)) + Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * ISS%water_flux(i,j)) / & + (mass_exch + ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) if (abs(dS_it) < 1e-4*(0.5*(state%sss(i,j) + Sbdry(i,j) + 1.e-10))) exit @@ -576,7 +582,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) exch_vel_t(i,j) = CS%gamma_t - ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_ocn(i,j) = US%QRZ_T_to_W_m2*RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) ISS%tflux_shelf(i,j) = 0.0 ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 @@ -603,17 +609,14 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) (ISS%area_shelf_h(i,j) > 0.0) .and. & (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then - ! Set melt to zero above a cutoff pressure - ! (CS%Rho0*CS%cutoff_depth*CS%g_Earth) this is needed for the isomip - ! test case. - if ((CS%g_Earth * ISS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & - CS%g_Earth) then - ISS%water_flux(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 + ! Set melt to zero above a cutoff pressure (CS%Rho0*CS%cutoff_depth*CS%g_Earth). + ! This is needed for the ISOMIP test case. + if ((ISS%mass_shelf(i,j)) < US%RZ_to_kg_m2*CS%Rho0*CS%cutoff_depth) then + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 endif ! Compute haline driving, which is one of the diags. used in ISOMIP - haline_driving(i,j) = (US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * Sbdry(i,j)) / & - (CS%Rho0 * exch_vel_s(i,j)) + haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho0 * exch_vel_s(i,j)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! !1)Check if haline_driving computed above is consistent with @@ -802,7 +805,8 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) !### Consider working over a smaller array range. do j=jsd,jed ; do i=isd,ied - press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) + press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & + US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) if (associated(forces%p_surf)) then if (.not.forces%accumulate_p_surf) forces%p_surf(i,j) = 0.0 forces%p_surf(i,j) = forces%p_surf(i,j) + press_ice @@ -817,7 +821,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! that it may have been zeroed out where IOB is translated to forces and ! contributions from icebergs and the sea-ice pack added subsequently. !### THE RIGIDITY SHOULD ALSO INCORPORATE AREAL-COVERAGE INFORMATION. - kv_rho_ice = CS%kv_ice / (US%R_to_kg_m3*CS%density_ice) + kv_rho_ice = US%Z2_T_to_m2_s*CS%kv_ice / (US%R_to_kg_m3*CS%density_ice) do j=js,je ; do I=is-1,ie if (.not.forces%accumulate_rigidity) forces%rigidity_ice_u(I,j) = 0.0 forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & @@ -854,7 +858,8 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) call MOM_error(FATAL,"add_shelf_pressure: Incompatible ocean and ice shelf grids.") do j=js,je ; do i=is,ie - press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) + press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & + US%Z_to_m*US%s_to_T**2*(CS%g_Earth * CS%ISS%mass_shelf(i,j)) if (associated(fluxes%p_surf)) then if (.not.fluxes%accumulate_p_surf) fluxes%p_surf(i,j) = 0.0 fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + press_ice @@ -876,7 +881,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. ! local variables - real :: Irho0 !< The inverse of the mean density [m3 kg-1]. + real :: Irho0 !< The inverse of the mean density times unit conversion factors that + !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. real :: frac_area !< The fractional area covered by the ice shelf [nondim]. real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). real :: shelf_mass1 !< Total ice shelf mass at current time (Time). @@ -933,7 +939,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) ! GMM: melting is computed using ustar_shelf (and not ustar), which has already ! been passed, I so believe we do not need to update fluxes%ustar. -! Irho0 = 1.0 / CS%Rho0 +! Irho0 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / CS%Rho0 ! do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. ! taux2 = 0.0 ; tauy2 = 0.0 @@ -948,7 +954,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + & ! asv2 * state%tauy_shelf(i,J)**2 ) / (asv1 + asv2) - ! fluxes%ustar(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s*sqrt(Irho0 * sqrt(taux2 + tauy2))) + ! fluxes%ustar(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) ! endif ; enddo ; enddo endif @@ -1061,11 +1067,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie ! Note the following is hard coded for ISOMIP if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - fluxes%vprec(i,j) = -mean_melt_flux * US%R_to_kg_m3*CS%density_ice/1000. ! evap is negative - ! Rescale fluxes%vprec to the proper units. - fluxes%vprec(i,j) = US%kg_m2s_to_RZ_T * fluxes%vprec(i,j) - fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*US%Q_to_J_kg*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] - fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) + ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] + fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T* mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif enddo ; enddo @@ -1173,6 +1178,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + !### This should be a run-time parameter that is read in consistently with MOM6 and SIS2. CS%Lat_fusion = 3.34e5*US%J_kg_to_Q CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. @@ -1212,7 +1218,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & "Depth above which the melt is set to zero (it must be >= 0) "//& - "Default value won't affect the solution.", default=0.0) + "Default value won't affect the solution.", default=0.0, scale=US%m_to_Z) !###, units="m" if (CS%cutoff_depth < 0.) & call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") @@ -1250,29 +1256,28 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "is computed from a quadratic equation. Otherwise, the previous "//& "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. - call get_param(param_file, mdl, "TFREEZE_S0_P0",CS%lambda1, & + call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%lambda1, & "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DS",CS%lambda1, & + call get_param(param_file, mdl, "DTFREEZE_DS", CS%lambda1, & !### This should be CS%lambda2! "this is the derivative of the freezing potential "//& "temperature with salinity.", & units="degC psu-1", default=-0.054, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DP",CS%lambda3, & + call get_param(param_file, mdl, "DTFREEZE_DP", CS%lambda3, & "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="degC Pa-1", default=0.0, do_not_log=.true.) - endif if (.not.CS%threeeq) & call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & "If SHELF_THREE_EQN is false, this the fixed turbulent "//& "exchange velocity at the ice-ocean interface.", & - units="m s-1", fail_if_missing=.true.) + units="m s-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + units="m s-2", default = 9.80, scale=US%m_to_Z*US%T_to_s**2) call get_param(param_file, mdl, "C_P", CS%Cp, & "The heat capacity of sea water.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & fail_if_missing=.true.) @@ -1281,7 +1286,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) !### MAKE THIS A SEPARATE PARAMETER. + units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) @@ -1291,10 +1296,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "fluxes.", units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & - "The viscosity of the ice.", units="m2 s-1", default=1.0e10) + "The viscosity of the ice.", units="m2 s-1", default=1.0e10, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & "The molecular kinimatic viscosity of sea water at the "//& - "freezing temperature.", units="m2 s-1", default=1.95e-6) + "freezing temperature.", units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & "The salinity of the ice inside the ice shelf.", units="psu", & default=0.0) @@ -1303,10 +1308,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl units = "degC", default=-15.0) call get_param(param_file, mdl, "KD_SALT_MOLECULAR", CS%kd_molec_salt, & "The molecular diffusivity of salt in sea water at the "//& - "freezing point.", units="m2 s-1", default=8.02e-10) + "freezing point.", units="m2 s-1", default=8.02e-10, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & "The molecular diffusivity of heat in sea water at the "//& - "freezing point.", units="m2 s-1", default=1.41e-7) + "freezing point.", units="m2 s-1", default=1.41e-7, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & "avg ocean density used in floatation cond", & units="kg m-3", default=1035.) @@ -1591,9 +1596,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_v_ml = register_diag_field('ocean_model', 'v_ml', CS%diag%axesCv1, CS%Time, & 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1') CS%id_exch_vel_s = register_diag_field('ocean_model', 'exch_vel_s', CS%diag%axesT1, CS%Time, & - 'Sub-shelf salinity exchange velocity', 'm s-1') + 'Sub-shelf salinity exchange velocity', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_exch_vel_t = register_diag_field('ocean_model', 'exch_vel_t', CS%diag%axesT1, CS%Time, & - 'Sub-shelf thermal exchange velocity', 'm s-1') + 'Sub-shelf thermal exchange velocity', 'm s-1' , conversion=US%Z_to_m*US%s_to_T) CS%id_tfreeze = register_diag_field('ocean_model', 'tfreeze', CS%diag%axesT1, CS%Time, & 'In Situ Freezing point at ice shelf interface', 'degC') CS%id_tfl_shelf = register_diag_field('ocean_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & From e1fcb3bc8c13a7ef58cb4fa6a542b088dd89dcd5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 22 Mar 2020 11:36:01 -0400 Subject: [PATCH 109/137] Changed the sign of ISS%tflux_ocn and rescaled it Changed the sign of ISS%tflux_ocn and ISS%tflux_shelf to comply with MOM6 sign conventions, and dimensionally rescaled these variables to [Q R Z T-1]. MOM_ice_shelf.F90, and added comments describing the units of other variables. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 44 +++++++++++++-------------- src/ice_shelf/MOM_ice_shelf_state.F90 | 10 +++--- 2 files changed, 26 insertions(+), 28 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 45ded4de39..da7015d7c3 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -248,8 +248,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness !! to the molecular boundary layer thickness [nondim]. !### THESE ARE CURRENTLY POSITIVE UPWARD. - real :: wT_flux !< The vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. - real :: wB_flux !< The vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. + real :: wT_flux !< The upward vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. + real :: wB_flux !< The upward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 degC-1 ~> m s-2 degC-1]. real :: I_n_star ! [nondim] @@ -313,8 +313,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! reasons, it is better to set them to zero again. exch_vel_t(:,:) = 0.0 ; exch_vel_s(:,:) = 0.0 ISS%tflux_shelf(:,:) = 0.0 ; ISS%water_flux(:,:) = 0.0 - ISS%salt_flux(:,:) = 0.0; ISS%tflux_ocn(:,:) = 0.0 - ISS%tfreeze(:,:) = 0.0 + ISS%salt_flux(:,:) = 0.0 ; ISS%tflux_ocn(:,:) = 0.0 ; ISS%tfreeze(:,:) = 0.0 ! define Sbdry to avoid Run-Time Check Failure, when melt is not computed. haline_driving(:,:) = 0.0 Sbdry(:,:) = state%sss(:,:) @@ -500,42 +499,41 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo !it3 endif - ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * US%Z_to_m*US%s_to_T*wT_flux + ISS%tflux_ocn(i,j) = -RhoCp * wT_flux exch_vel_t(i,j) = ustar_h * I_Gam_T exch_vel_s(i,j) = ustar_h * I_Gam_S !Calculate the heat flux inside the ice shelf. !vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). - ! Q_ice = rho_ice * CS%Cp_ice * K_ice * dT/dz (at interface) + ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) !vertical adv/diff as in H+J 199, eqs (31) & (26)... - ! dT/dz ~= min( (lprec/(rho_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) + ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) !If this approximation is not made, iterations are required... See H+J Fig 3. - if (ISS%tflux_ocn(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) + if (ISS%tflux_ocn(i,j) >= 0.0) then ! Freezing occurs due to downward ocean heat flux, so zero ice heat flux. + ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) ISS%tflux_shelf(i,j) = 0.0 else if (CS%insulator) then !no conduction/perfect insulator ISS%tflux_shelf(i,j) = 0.0 - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * (- ISS%tflux_shelf(i,j) + ISS%tflux_ocn(i,j)) + ISS%water_flux(i,j) = I_LF * (ISS%tflux_shelf(i,j) - ISS%tflux_ocn(i,j)) else ! With melting, from H&J 1999, eqs (31) & (26)... ! Q_ice ~= Cp_ice * (CS%Temp_Ice-T_freeze) * lprec - ! RhoLF*lprec = Q_ice + ISS%tflux_ocn(i,j) - ! lprec = (ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * ISS%tflux_ocn(i,j) / & - (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + ! RhoLF*lprec = Q_ice - ISS%tflux_ocn(i,j) + ! lprec = -(ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = -ISS%tflux_ocn(i,j) / (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) - ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - CS%Lat_fusion*US%QRZ_T_to_W_m2*ISS%water_flux(i,j) + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) + CS%Lat_fusion*ISS%water_flux(i,j) endif endif - !other options: dTi/dz linear through shelf - ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j))/G%draft(i,j) - ! ISS%tflux_shelf(i,j) = - Rho_Ice * US%Q_to_J_kg*CS%Cp_ice * KTI * dTi_dz + !other options: dTi/dz linear through shelf, with draft in [Z ~> m], KTI in [Z2 T-1 ~> m2 s-1] + ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j)) / draft(i,j) + ! ISS%tflux_shelf(i,j) = Rho_Ice * CS%Cp_ice * KTI * dTi_dz if (CS%find_salt_root) then @@ -582,9 +580,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) exch_vel_t(i,j) = CS%gamma_t - ISS%tflux_ocn(i,j) = US%QRZ_T_to_W_m2*RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - state%sst(i,j)) ISS%tflux_shelf(i,j) = 0.0 - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) + ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif else !not shelf @@ -985,7 +983,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif if (associated(fluxes%sens)) & - fluxes%sens(i,j) = -frac_area*ISS%tflux_ocn(i,j)*US%W_m2_to_QRZ_T*CS%flux_factor + fluxes%sens(i,j) = frac_area*ISS%tflux_ocn(i,j)*CS%flux_factor if (associated(fluxes%salt_flux)) & fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor endif ; enddo ; enddo @@ -1068,7 +1066,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! Note the following is hard coded for ISOMIP if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T* mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T*mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif @@ -1602,7 +1600,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_tfreeze = register_diag_field('ocean_model', 'tfreeze', CS%diag%axesT1, CS%Time, & 'In Situ Freezing point at ice shelf interface', 'degC') CS%id_tfl_shelf = register_diag_field('ocean_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & - 'Heat conduction into ice shelf', 'W m-2') + 'Heat conduction into ice shelf', 'W m-2', conversion=-US%QRZ_T_to_W_m2) CS%id_ustar_shelf = register_diag_field('ocean_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T) if (CS%active_shelf_dynamics) then diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index ac34817482..98b5d01939 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -37,14 +37,14 @@ module MOM_ice_shelf_state !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED !! otherwise the wrong nodes will be included in velocity calcs. - tflux_ocn => NULL(), & !< The UPWARD sensible ocean heat flux at the - !! ocean-ice interface [m-2]. + tflux_ocn => NULL(), & !< The downward sensible ocean heat flux at the + !! ocean-ice interface [Q R Z T-1 ~> W m-2]. salt_flux => NULL(), & !< The downward salt flux at the ocean-ice - !! interface [kg m-2 s-1]. + !! interface [kgSalt kgWater-1 R Z T-1 ~> kgSalt m-2 s-1]. water_flux => NULL(), & !< The net downward liquid water flux at the !! ocean-ice interface [R Z T-1 ~> kg m-2 s-1]. - tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice - !! shelf at the ice-ocean interface [W m-2]. + tflux_shelf => NULL(), & !< The downward diffusive heat flux in the ice + !! shelf at the ice-ocean interface [Q R Z T-1 ~> W m-2]. tfreeze => NULL() !< The freezing point potential temperature !! an the ice-ocean interface [degC]. From 27bffdbf510a76c01c7c9b76363bd522158eefd6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 22 Mar 2020 15:04:38 -0400 Subject: [PATCH 110/137] +Rescaled ISS%shelf_mass to [R Z] Rescaled the viarable ISS%shelf_mass to [R Z} for dimensional consistency testing and code simplification. This also required the addition of a new scaling factor to the ice_shelf restart files. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 92 ++++++++++++++---------- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_state.F90 | 4 +- src/ice_shelf/user_shelf_init.F90 | 9 ++- 4 files changed, 62 insertions(+), 45 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index da7015d7c3..62d00e283b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -100,7 +100,6 @@ module MOM_ice_shelf real :: Temp_ice !< The core temperature of shelf ice [degC]. real :: kv_ice !< The viscosity of ice [Z2 T-1 ~> m2 s-1]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. - real :: rho_ice !< Nominal ice density [kg m-2 Z-1 ~> kg m-3]. real :: kv_molec !< The molecular kinematic viscosity of sea water [Z2 T-1 ~> m2 s-1]. real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1]. real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. @@ -233,7 +232,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. -!### real :: LF !< Latent Heat of fusion [J kg-1]. real :: I_LF !< The inverse of the latent Heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of VK. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. @@ -293,7 +291,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed I_ZETA_N = 1.0 / ZETA_N -!### LF = US%Q_to_J_kg*CS%Lat_fusion I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp @@ -324,7 +321,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%override_shelf_movement) then CS%time_step = time_step ! update shelf mass - if (CS%mass_from_file) call update_shelf_mass(G, CS, ISS, Time) + if (CS%mass_from_file) call update_shelf_mass(G, US, CS, ISS, Time) endif if (CS%debug) then @@ -339,7 +336,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. - do i=is,ie ; p_int(i) = US%Z_to_m*US%s_to_T**2*CS%g_Earth * ISS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*CS%g_Earth * ISS%mass_shelf(i,j) ; enddo ! Calculate insitu densities and expansion coefficients call calculate_density(state%sst(:,j), state%sss(:,j), p_int, & @@ -451,7 +448,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif wT_flux = dT_ustar * I_Gam_T - wB_flux = dB_dS * (dS_ustar * I_Gam_S) + US%Z_to_m*US%s_to_T**2*dB_dT * wT_flux + wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux if (wB_flux > 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent @@ -511,7 +508,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) !If this approximation is not made, iterations are required... See H+J Fig 3. - if (ISS%tflux_ocn(i,j) >= 0.0) then ! Freezing occurs due to downward ocean heat flux, so zero ice heat flux. + if (ISS%tflux_ocn(i,j) >= 0.0) then + ! Freezing occurs due to downward ocean heat flux, so zero iout ce heat flux. ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) ISS%tflux_shelf(i,j) = 0.0 else @@ -525,7 +523,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Q_ice ~= Cp_ice * (CS%Temp_Ice-T_freeze) * lprec ! RhoLF*lprec = Q_ice - ISS%tflux_ocn(i,j) ! lprec = -(ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) - ISS%water_flux(i,j) = -ISS%tflux_ocn(i,j) / (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + ISS%water_flux(i,j) = -ISS%tflux_ocn(i,j) / & + (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) + CS%Lat_fusion*ISS%water_flux(i,j) endif @@ -609,9 +608,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Set melt to zero above a cutoff pressure (CS%Rho0*CS%cutoff_depth*CS%g_Earth). ! This is needed for the ISOMIP test case. - if ((ISS%mass_shelf(i,j)) < US%RZ_to_kg_m2*CS%Rho0*CS%cutoff_depth) then - ISS%water_flux(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 + if (ISS%mass_shelf(i,j) < CS%Rho0*CS%cutoff_depth) then + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 endif ! Compute haline driving, which is one of the diags. used in ISOMIP haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho0 * exch_vel_s(i,j)) @@ -651,11 +650,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Melting has been computed, now is time to update thickness and mass if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then - call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%rho_ice, CS%debug) + call change_thickness_using_melt(ISS, G, US, US%s_to_T*time_step, fluxes, CS%density_ice, CS%debug) if (CS%debug) then call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) - call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) endif endif @@ -690,7 +690,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, ISS%tflux_shelf, CS%diag) if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,ISS%h_shelf,CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) call disable_averaging(CS%diag) @@ -706,21 +706,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) end subroutine shelf_calc_flux !> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting -subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug) +subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ice, debug) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state - real, intent(in) :: time_step !< The time step for this update [s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: time_step !< The time step for this update [T ~> s]. type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible !! thermodynamic or mass-flux forcing fields. - real, intent(in) :: rho_ice !< The density of ice-shelf ice [kg m-2 Z-1 ~> kg m-3]. + real, intent(in) :: density_ice !< The density of ice-shelf ice [R ~> kg m-3]. logical, optional, intent(in) :: debug !< If present and true, write chksums ! locals - real :: I_rho_ice + real :: I_rho_ice ! Ice specific volume [R-1 ~> m3 kg-1] integer :: i, j - I_rho_ice = 1.0 / rho_ice + I_rho_ice = 1.0 / density_ice + do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then @@ -730,8 +732,8 @@ subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - if (G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice < ISS%h_shelf(i,j)) then - ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice + if (ISS%water_flux(i,j) * time_step / density_ice < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(i,j) * time_step / density_ice else ! the ice is about to melt away, so set thickness, area, and mask to zero ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell @@ -749,7 +751,7 @@ subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug !### combine this with the loops above. do j=G%jsd,G%jed ; do i=G%isd,G%ied if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*rho_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice endif enddo ; enddo @@ -766,7 +768,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. - real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1]. + real :: kv_rho_ice ! The viscosity of ice divided by its density [m3 s-1 R-1 Z-1 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. logical :: find_area ! If true find the shelf areas at u & v points. type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe @@ -804,7 +806,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) !### Consider working over a smaller array range. do j=jsd,jed ; do i=isd,ied press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & - US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) + US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) if (associated(forces%p_surf)) then if (.not.forces%accumulate_p_surf) forces%p_surf(i,j) = 0.0 forces%p_surf(i,j) = forces%p_surf(i,j) + press_ice @@ -819,7 +821,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! that it may have been zeroed out where IOB is translated to forces and ! contributions from icebergs and the sea-ice pack added subsequently. !### THE RIGIDITY SHOULD ALSO INCORPORATE AREAL-COVERAGE INFORMATION. - kv_rho_ice = US%Z2_T_to_m2_s*CS%kv_ice / (US%R_to_kg_m3*CS%density_ice) + kv_rho_ice = US%Z_to_m*US%Z2_T_to_m2_s*CS%kv_ice / CS%density_ice do j=js,je ; do I=is-1,ie if (.not.forces%accumulate_rigidity) forces%rigidity_ice_u(I,j) = 0.0 forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & @@ -857,7 +859,7 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) do j=js,je ; do i=is,ie press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & - US%Z_to_m*US%s_to_T**2*(CS%g_Earth * CS%ISS%mass_shelf(i,j)) + US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * CS%ISS%mass_shelf(i,j)) if (associated(fluxes%p_surf)) then if (.not.fluxes%accumulate_p_surf) fluxes%p_surf(i,j) = 0.0 fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + press_ice @@ -895,7 +897,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: t0 !< The previous time (Time-dt) [s]. type(time_type) :: Time0!< The previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass - !! at at previous time (Time-dt) [kg m-2] + !! at at previous time (Time-dt) [R Z ~> kg m-2] real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness [Z ~> m] !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask @@ -1023,14 +1025,16 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) Time0 = real_to_time(t0) last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) - last_h_shelf(:,:) = last_mass_shelf(:,:) / CS%rho_ice + ! This should only be done if time_interp_external did an update. + last_mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(:,:) ! Rescale after time_interp + last_h_shelf(:,:) = last_mass_shelf(:,:) / CS%density_ice ! apply calving if (CS%min_thickness_simple_calve > 0.0) then call ice_shelf_min_thickness_calve(G, last_h_shelf, last_area_shelf_h, last_hmask, & CS%min_thickness_simple_calve) ! convert to mass again - last_mass_shelf(:,:) = last_h_shelf(:,:) * CS%rho_ice + last_mass_shelf(:,:) = last_h_shelf(:,:) * CS%density_ice endif shelf_mass0 = 0.0; shelf_mass1 = 0.0 @@ -1039,8 +1043,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! just floating shelf (0.1 is a threshold for min ocean thickness) if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then - shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * US%L_to_m**2*ISS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * US%L_to_m**2*ISS%area_shelf_h(i,j)) + shelf_mass0 = shelf_mass0 + US%RZ_to_kg_m2*US%L_to_m**2*(last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + shelf_mass1 = shelf_mass1 + US%RZ_to_kg_m2*US%L_to_m**2*(ISS%mass_shelf(i,j) * ISS%area_shelf_h(i,j)) endif enddo ; enddo call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) @@ -1106,6 +1110,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl type(dyn_horgrid_type), pointer :: dG => NULL() real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. + real :: RZ_rescale ! A rescaling factor for mass loads from the representation in + ! a restart file to the internal representation in this run. real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in ! a restart file to the internal representation in this run. real :: cdrag, drag_bg_vel @@ -1362,7 +1368,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=900.0, scale=US%kg_m3_to_R) endif - CS%rho_ice = CS%density_ice*US%Z_to_m*US%R_to_kg_m3 call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & "Min thickness rule for the very simple calving law",& @@ -1431,6 +1436,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "Height unit conversion factor", "Z meter-1") call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & "Length unit conversion factor", "L meter-1") + call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & + "Density unit conversion factor", "R m3 kg-1") if (CS%active_shelf_dynamics) then call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & "ice sheet/shelf thickness mask" ,"none") @@ -1465,7 +1472,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%rho_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1493,7 +1500,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%rho_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1511,6 +1518,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl enddo ; enddo endif + if ((US%m_to_Z_restart*US%kg_m3_to_R_restart /= 0.0) .and. & + (US%m_to_Z*US%kg_m3_to_R /= US%m_to_Z_restart * US%kg_m3_to_R_restart)) then + RZ_rescale = US%m_to_Z*US%kg_m3_to_R / (US%m_to_Z_restart * US%kg_m3_to_R_restart) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ISS%mass_shelf(i,j) = RZ_rescale * ISS%mass_shelf(i,j) + enddo ; enddo + endif + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then L_rescale = US%m_to_L / US%m_to_L_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -1575,7 +1590,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_area_shelf_h = register_diag_field('ocean_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & 'Ice Shelf Area in cell', 'meter-2', conversion=US%L_to_m**2) CS%id_shelf_mass = register_diag_field('ocean_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & - 'mass of shelf', 'kg/m^2') + 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_m) CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& @@ -1695,8 +1710,9 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) end subroutine initialize_shelf_mass !> Updates the ice shelf mass using data from a file. -subroutine update_shelf_mass(G, CS, ISS, Time) +subroutine update_shelf_mass(G, US, CS, ISS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated type(time_type), intent(in) :: Time !< The current model time @@ -1706,13 +1722,15 @@ subroutine update_shelf_mass(G, CS, ISS, Time) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) + ! This should only be done if time_interp_external did an update. + ISS%mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * ISS%mass_shelf(:,:) ! Rescale after time_interp do j=js,je ; do i=is,ie ISS%area_shelf_h(i,j) = 0.0 ISS%hmask(i,j) = 0. if (ISS%mass_shelf(i,j) > 0.0) then ISS%area_shelf_h(i,j) = G%areaT(i,j) - ISS%h_shelf(i,j) = ISS%mass_shelf(i,j) / CS%rho_ice + ISS%h_shelf(i,j) = ISS%mass_shelf(i,j) / CS%density_ice ISS%hmask(i,j) = 1. endif enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index cf82092dc5..e8d6f9b3c1 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1969,7 +1969,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) ISS%area_shelf_h(i,j) = dxdyh elseif ((partial_vol / dxdyh) < h_reference) then ISS%hmask(i,j) = 2 - ! ISS%mass_shelf(i,j) = G%US%L_to_m**2*partial_vol * rho + ! ISS%mass_shelf(i,j) = G%US%L_to_Z*G%US%L_to_m*partial_vol * G%US%kg_m3_to_R*rho ISS%area_shelf_h(i,j) = partial_vol / h_reference ISS%h_shelf(i,j) = h_reference else diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 98b5d01939..b3e88697f2 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -23,9 +23,9 @@ module MOM_ice_shelf_state !> Structure that describes the ice shelf state type, public :: ice_shelf_state real, pointer, dimension(:,:) :: & - mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [kg m-2]. + mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [R Z ~> kg m-2]. area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. - h_shelf => NULL(), & !< the thickness of the shelf [m], redundant with mass but may + h_shelf => NULL(), & !< the thickness of the shelf [Z ~> m], redundant with mass but may !! make the code more readable hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells !! 1: fully covered, solve for velocity here (for now all diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 100f8e652a..54b452fc6a 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -27,7 +27,7 @@ module user_shelf_init !> The control structure for the user_ice_shelf module type, public :: user_ice_shelf_CS ; private - real :: Rho_ocean !< The ocean's typical density [kg m-2 Z-1]. + real :: Rho_ocean !< The ocean's typical density [R ~> kg m-3]. real :: max_draft !< The maximum ocean draft of the ice shelf [Z ~> m]. real :: min_draft !< The minimum ocean draft of the ice shelf [Z ~> m]. real :: flat_shelf_width !< The range over which the shelf is min_draft thick [km]. @@ -45,7 +45,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: mass_shelf !< The ice shelf mass per unit area averaged - !! over the full ocean cell [kg m-2]. + !! over the full ocean cell [R Z ~> kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -60,7 +60,6 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, !! being started from a restart file. ! This subroutine sets up the initial mass and area covered by the ice shelf. - real :: Rho_ocean ! The ocean's typical density [kg m-3]. real :: max_draft ! The maximum ocean draft of the ice shelf [Z ~> m]. real :: min_draft ! The minimum ocean draft of the ice shelf [Z ~> m]. real :: flat_shelf_width ! The range over which the shelf is min_draft thick. @@ -81,7 +80,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%Z_to_m) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, & units="m", default=1.0, scale=US%m_to_Z) call get_param(param_file, mdl, "SHELF_MIN_DRAFT", CS%min_draft, & @@ -126,7 +125,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: mass_shelf !< The ice shelf mass per unit area averaged - !! over the full ocean cell [kg m-2]. + !! over the full ocean cell [R Z ~> kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & From 81974e1f3b4fa1a92eab3c6c5acd459fd7ab5863 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 24 Mar 2020 11:53:09 -0400 Subject: [PATCH 111/137] +Changed units of forcing%ice_shelf_melt Changed the units of forcing%ice_shelf_melt to [R Z T-1 ~> kg m-2 s-1] and removed some unused variables. Diagnostics based on forcing%ice_shelf_melt have been rescaled so they retain their old units and values. All answers in MOM6-examples test cases are bitwise identical, including the ISOMIP test case. --- src/core/MOM_forcing_type.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 21 +++++++++------------ src/tracer/ISOMIP_tracer.F90 | 4 ++-- 3 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ebafa1d47a..b7260c2da6 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -149,7 +149,7 @@ module MOM_forcing_type !! associated if ice shelves are enabled, and are !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) - !! or freezing (negative) [Z year-1 ~> m year-1] + !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 62d00e283b..848c8ff06b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -279,7 +279,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real, parameter :: c2_3 = 2.0/3.0 character(len=160) :: mesg ! The text of an error message integer :: i, j, is, ie, js, je, ied, jed, it1, it3 - real, parameter :: rho_fw = 1000.0 ! fresh water density if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") @@ -594,12 +593,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo ! j-loop ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] - ! We want melt in m/year - if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/rho_fw) * CS%flux_factor - else ! use original eq. - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/CS%density_ice) * CS%flux_factor - endif + fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & @@ -907,8 +901,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state - real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1] - real :: rho_fw = 1000.0 ! Fresh water density [R ~> kg m-3] character(len=160) :: mesg ! The text of an error message integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -920,7 +912,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ISS => CS%ISS - rho_fw = 1000.0*US%kg_m3_to_R ! fresh water density call add_shelf_pressure(G, US, CS, fluxes) @@ -1049,7 +1040,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) enddo ; enddo call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step -! delta_mass_shelf = (shelf_mass1 - shelf_mass0) * (rho_fw/(CS%density_ice*CS%time_step)) ! write(mesg,*) 'delta_mass_shelf = ', delta_mass_shelf ! call MOM_mesg(mesg,5) else! first time step @@ -1114,6 +1104,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! a restart file to the internal representation in this run. real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in ! a restart file to the internal representation in this run. + real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1596,8 +1587,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', & 'kg/s', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) + + if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw = 1000. kg m-3 + meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / (1000.0*US%kg_m3_to_R) + else ! use original eq. + meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / CS%density_ice + endif CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Melt Rate', 'm yr-1', conversion=US%Z_to_m) + 'Ice Shelf Melt Rate', 'm yr-1', conversion= meltrate_conversion) CS%id_thermal_driving = register_diag_field('ocean_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') CS%id_haline_driving = register_diag_field('ocean_model', 'haline_driving', CS%diag%axesT1, CS%Time, & diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index a711437191..95d451791e 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -279,8 +279,8 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G real :: b1(SZI_(G)) ! b1 and c1 are variables used by the real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified - real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [Z year-1 ~> m year-1] - real :: mmax ! The global maximum melting rate [Z year-1 ~> m year-1] + real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [R Z T-1 ~> kg m-2 s-1] + real :: mmax ! The global maximum melting rate [R Z T-1 ~> kg m-2 s-1] character(len=256) :: mesg ! The text of an error message integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke From f3177f447565cf9188d9b4a32469645c1db89e28 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 24 Mar 2020 16:18:24 -0400 Subject: [PATCH 112/137] +Rescaled lengths in MOM_ice_shelf_dynamics.F90 Added dimensional rescaling of horizontal lengths in many variables in MOM_ice_shelf_dynamics.F90 and added comments describing many of the variables and their units. Some unused variables were eliminated, and other internal variables were renamed (e.g., u became u_shlf) for greater clarity and to ensure that all instances variables were properly rescaled. As a part of this change, the units of the ocean_mass argument to update_ice_shelf were changed. All answers in MOM6-examples test cases are bitwise identical, but it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf.F90 | 3 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1036 ++++++++++---------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 24 +- 3 files changed, 537 insertions(+), 526 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 848c8ff06b..8299d954b2 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -665,7 +665,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it - call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, state%ocean_mass, coupled_GL) + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & + US%kg_m3_to_R*US%m_to_Z*state%ocean_mass(:,:), coupled_GL) endif diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index e8d6f9b3c1..0fc319c621 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -40,9 +40,9 @@ module MOM_ice_shelf_dynamics !> The control structure for the ice shelf dynamics. type, public :: ice_shelf_dyn_CS ; private real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal (?) velocity of the ice shelf/sheet - !! on q-points (B grid) [m s-1]?? + !! on q-points (B grid) [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet - !! on q-points (B grid) [m s-1]?? + !! on q-points (B grid) [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, @@ -56,10 +56,10 @@ module MOM_ice_shelf_dynamics !! v-face, with valued defined similarly to u_face_mask. real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? - real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux into the cell through open boundary - !! u-faces (where u_face_mask=4) [Z m2 s-1 ~> m3 s-1]?? - real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux into the cell through open boundary - !! v-faces (where v_face_mask=4) [Z m2 s-1 ~> m3 s-1]?? + real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell + !! through open boundary u-faces (where u_face_mask=4) [Z L s-1 ~> m2 s-1] + real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell + !! through open boundary v-faces (where v_face_mask=4) [Z L s-1 ~> m2 s-1]?? ! needed where u_face_mask is equal to 4, similary for v_face_mask real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) !! 1=normal node, 3=inhomogeneous boundary node, @@ -74,12 +74,15 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, perhaps in [m]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. - real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries [m s-1]?? - real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries [m s-1]?? + real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries + !! [L yr-1 ~> m yr-1] + real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries + !! [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. real, pointer, dimension(:,:) :: taub_beta_eff => NULL() !< nonlinear part of "linearized" basal stress. + !! [L-2 ? ~> m-2 ?] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. @@ -98,8 +101,8 @@ module MOM_ice_shelf_dynamics ! meaning if it is done too frequently. real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last udated [s]. - real :: g_Earth !< The gravitational acceleration [m s-2]. - real :: density_ice !< A typical density of ice [kg m-3]. + real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. + real :: density_ice !< A typical density of ice [R ~> kg m-3]. logical :: GL_regularize !< Specifies whether to regularize the floatation condition !! at the grounding line as in Goldberg Holland Schoof 2009 @@ -116,16 +119,16 @@ module MOM_ice_shelf_dynamics real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs !! i.e. dt <= CFL_factor * min(dx / u) - real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Lawa, [Pa-1/3 year]. + real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-1/3 year]. real :: n_glen !< Nonlinearity exponent in Glen's Law real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. real :: C_basal_friction !< Ceofficient in sliding law tau_b = C u^(n_basal_friction), in !! units="Pa (m-a)-(n_basal_friction) real :: n_basal_friction !< Exponent in sliding law tau_b = C u^(m_slide) - real :: density_ocean_avg !< This does not affect ocean circulation or thermodynamics. - !! It is used to estimate the gravitational driving force at the - !! shelf front (until we think of a better way to do it, - !! but any difference will be negligible). + real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean + !! circulation or thermodynamics. It is used to estimate the + !! gravitational driving force at the shelf front (until we think of + !! a better way to do it, but any difference will be negligible). real :: thresh_float_col_depth !< The water column depth over which the shelf if considered to be floating logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve). logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. @@ -162,11 +165,12 @@ module MOM_ice_shelf_dynamics contains !> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) +!! The return value is between 0 and 2 [nondim]. function slope_limiter(num, denom) real, intent(in) :: num !< The numerator of the ratio used in the Van Leer slope limiter real, intent(in) :: denom !< The denominator of the ratio used in the Van Leer slope limiter - real :: slope_limiter - real :: r + real :: slope_limiter ! The slope limiter value, between 0 and 2 [nondim]. + real :: r ! The ratio of num/denom [nondim] if (denom == 0) then slope_limiter = 0 @@ -181,9 +185,10 @@ end function slope_limiter !> Calculate area of quadrilateral. function quad_area (X, Y) - real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. - real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. - real :: quad_area, p2, q2, a2, c2, b2, d2 + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. + real :: quad_area ! Computed area [L2 ~> m2] + real :: p2, q2, a2, c2, b2, d2 ! X and Y must be passed in the form ! 3 - 4 @@ -267,7 +272,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ !! the ice-shelf state type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise !! has been started from a restart file. @@ -277,6 +282,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Local variables real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. + real :: L_rescale ! A rescaling factor for horizontal lenghts from the representation in + ! a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" character(len=200) :: config @@ -342,14 +349,14 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & "avg ocean density used in floatation cond", & - units="kg m-3", default=1035.) + units="kg m-3", default=1035., scale=US%kg_m3_to_R) if (active_shelf_dynamics) then call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & "seconds between ice velocity calcs", units="s", & fail_if_missing=.true.) call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & "Ice viscosity parameter in Glen's Law", & @@ -367,7 +374,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "exponent in sliding law \tau_b = C u^(m_slide)", & units="none", fail_if_missing=.true.) call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & - "A typical density of ice.", units="kg m-3", default=917.0) + "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & "tolerance in CG solver, relative to initial residual", default=1.e-6) call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & @@ -440,12 +447,21 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo endif + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then + L_rescale = US%m_to_L / US%m_to_L_restart + do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec + CS%u_shelf(I,J) = L_rescale * CS%u_shelf(I,J) + CS%v_shelf(I,J) = L_rescale * CS%v_shelf(I,J) + enddo ; enddo + endif + ! this is unfortunately necessary; if grid is not symmetric the boundary values ! of u and v are otherwise not set till the end of the first linear solve, and so ! viscosity is not calculated correctly. ! This has to occur after init_boundary_values or some of the arrays on the ! right hand side have not been set up yet. if (.not. G%symmetric) then + !### What about v_shelf? do j=G%jsd,G%jed ; do i=G%isd,G%ied if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) @@ -498,15 +514,15 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf, iters, Time) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf,CS%diag) endif ! Register diagnostics. CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1, Time, & - 'x-velocity of ice', 'm yr-1') + 'x-velocity of ice', 'm yr-1', conversion=US%L_to_m) CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & - 'y-velocity of ice', 'm yr-1') + 'y-velocity of ice', 'm yr-1', conversion=US%L_to_m) CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1, Time, & @@ -541,7 +557,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(time_type), intent(in) :: Time !< The current model time integer :: i, j, iters, isd, ied, jsd, jed @@ -579,20 +595,21 @@ function ice_time_step_CFL(CS, ISS, G) type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. real :: ice_time_step_CFL !< The maximum permitted timestep based on the ice velocities [s]. - real :: ratio, min_ratio - real :: local_u_max, local_v_max + real :: ratio, min_ratio ! These should be the minimum stable timesteps at a CFL of 1 [years] + real :: local_u_max, local_v_max ! The largest neighboring velocities [L yr-1 ~> m yr-1] integer :: i, j - min_ratio = 1.0e16 ! This is just an arbitrary large nondiensional value. + min_ratio = 1.0e16 ! This is just an arbitrary large nondimensional value. do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then local_u_max = max(abs(CS%u_shelf(i,j)), abs(CS%u_shelf(i+1,j+1)), & abs(CS%u_shelf(i+1,j)), abs(CS%u_shelf(i,j+1))) local_v_max = max(abs(CS%v_shelf(i,j)), abs(CS%v_shelf(i+1,j+1)), & abs(CS%v_shelf(i+1,j)), abs(CS%v_shelf(i,j+1))) - ! Here the hard-coded 1e-12 has units of m s-1. Consider revising. - ratio = G%US%L_to_m**2*min(G%areaT(i,j) / (local_u_max + 1.0e-12), & - G%areaT(i,j) / (local_v_max + 1.0e-12)) + ! Here the hard-coded 1e-12 has units of m year-1. Consider revising. + !### Ratio should be a timestep in {s] or [yr], but this expression appears to be in [m yr] + ratio = G%US%L_to_m*min(G%areaT(i,j) / (local_u_max + 1.0e-12*G%US%m_to_L), & + G%areaT(i,j) / (local_v_max + 1.0e-12*G%US%m_to_L)) min_ratio = min(min_ratio, ratio) endif ; enddo ; enddo ! i- and j- loops @@ -610,12 +627,12 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< time step [s] type(time_type), intent(in) :: Time !< The current model time real, dimension(SZDI_(G),SZDJ_(G)), & optional, intent(in) :: ocean_mass !< If present this is the mass per unit area - !! of the ocean [kg m-2]. + !! of the ocean [R Z ~> kg m-2]. logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is !! determined by coupled ice-ocean dynamics logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. @@ -648,8 +665,8 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (update_ice_vel) then call enable_averaging(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) @@ -709,11 +726,11 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell + ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy + real :: spy - rho = CS%density_ice spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -769,22 +786,25 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) end subroutine ice_shelf_advect -subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) +subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u !< The zonal ice shelf velocity at vertices [m year-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v !< The meridional ice shelf velocity at vertices [m year-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & - u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, & - u_last, v_last + real, dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY ! Driving stresses at q-points [kg L s-2 ~> kg m s-2] + ! The units should be [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont, v_bdry_cont ! Boundary velocity contributions [L yr-1 ~> m yr-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! A term in the momentum balance [L ? ~> m ?] + real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. @@ -792,14 +812,17 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) integer :: conv_flag, i, j, k,l, iter integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi_rhow - real, pointer, dimension(:,:,:,:) :: Phi => NULL() - real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() - real, dimension(8,4) :: Phi_temp - real, dimension(2,2) :: X,Y + real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian + ! quadrature points surrounding the cell verticies [m-1]. + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale + ! locations for finite element calculations [nondim] + real, dimension(8,4) :: Phi_temp ! The gradients of bilinear basis elements at Gaussian + ! quadrature points surrounding a cell vertex [L-1 ~> m-1]. + real, dimension(2,2) :: X, Y ! Positions on cell [L ~> m] character(2) :: iternum character(2) :: numproc - ! for GL interpolation - need to make this a readable parameter + ! for GL interpolation nsub = CS%n_sub_regularize isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB @@ -811,8 +834,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) Au(:,:) = 0.0 ; Av(:,:) = 0.0 ! need to make these conditional on GL interpolation - float_cond(:,:) = 0.0 ; H_node(:,:)=0 - allocate(Phisub (nsub,nsub,2,2,2,2)) ; Phisub = 0.0 + float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 + allocate(Phisub(nsub,nsub,2,2,2,2)) ; Phisub(:,:,:,:,:,:) = 0.0 isumstart = G%isc ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. @@ -862,28 +885,25 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) ! make above conditional - u_prev_iterate(:,:) = u(:,:) - v_prev_iterate(:,:) = v(:,:) - - ! must prepare phi + ! must prepare Phi allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:) = 0.0 do j=jsd,jed ; do i=isd,ied if (((i > isd) .and. (j > jsd))) then - X(:,:) = G%geoLonBu(i-1:i,j-1:j)*1000 - Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000 + X(:,:) = G%geoLonBu(i-1:i,j-1:j)*1000.0*US%m_to_L + Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000.0*US%m_to_L else - X(2,:) = G%geoLonBu(i,j)*1000 - X(1,:) = G%geoLonBu(i,j)*1000 - US%L_to_m*G%dxT(i,j) - Y(:,2) = G%geoLatBu(i,j)*1000 - Y(:,1) = G%geoLatBu(i,j)*1000 - US%L_to_m*G%dyT(i,j) + X(2,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L + X(1,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L - G%dxT(i,j) + Y(:,2) = G%geoLatBu(i,j)*1000.0*US%m_to_L + Y(:,1) = G%geoLatBu(i,j)*1000.0*US%m_to_L - G%dyT(i,j) endif call bilinear_shape_functions(X, Y, Phi_temp, area) Phi(i,j,:,:) = Phi_temp enddo ; enddo - call calc_shelf_visc(CS, ISS, G, US, u, v) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) call pass_var(CS%taub_beta_eff, G%domain) @@ -894,24 +914,23 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_frac(i,j) enddo ; enddo - call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, & - rhoi_rhow, u_bdry_cont, v_bdry_cont) + call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, G%US%L_to_m**2*G%areaT, & - G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) err_init = 0 ; err_tempu = 0; err_tempv = 0 do j=jsumstart,G%jecB do i=isumstart,G%iecB if (CS%umask(i,j) == 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + err_tempu = ABS(Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) endif if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + err_tempv = MAX(ABS(Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) endif if (err_tempv >= err_init) then err_init = err_tempv @@ -921,27 +940,27 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) call max_across_PEs(err_init) - write(mesg,*) "ice_shelf_solve_outer: INITIAL nonlinear residual = ",err_init + write(mesg,*) "ice_shelf_solve_outer: INITIAL nonlinear residual = ", err_init*US%L_to_m call MOM_mesg(mesg, 5) - u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) + u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) !! begin loop do iter=1,100 - call ice_shelf_solve_inner(CS, ISS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & + call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, TAUDX, TAUDY, H_node, float_cond, & ISS%hmask, conv_flag, iters, time, Phi, Phisub) if (CS%debug) then - call qchksum(u, "u shelf", G%HI, haloshift=2) - call qchksum(v, "v shelf", G%HI, haloshift=2) + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_to_m) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_to_m) endif write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" call MOM_mesg(mesg, 5) - call calc_shelf_visc(CS, ISS, G, US, u, v) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) call pass_var(CS%taub_beta_eff, G%domain) @@ -953,27 +972,27 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & CS%taub_beta_eff, float_cond, & rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, G%US%L_to_m**2*G%areaT, & - G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) err_max = 0 - if (CS%nonlin_solve_err_mode == 1) then + if (CS%nonlin_solve_err_mode == 1) then do j=jsumstart,G%jecB do i=isumstart,G%iecB if (CS%umask(i,j) == 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + err_tempu = ABS(Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) endif if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + err_tempv = MAX(ABS(Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) endif if (err_tempv >= err_max) then err_max = err_tempv @@ -990,12 +1009,12 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) do j=jsumstart,G%jecB do i=isumstart,G%iecB if (CS%umask(i,j) == 1) then - err_tempu = ABS (u_last(i,j)-u(i,j)) - tempu = u(i,j) + err_tempu = ABS(u_last(i,j)-u_shlf(I,J)) + tempu = u_shlf(I,J) endif if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) - tempv = SQRT(v(i,j)**2+tempu**2) + err_tempv = MAX(ABS(v_last(i,j)-v_shlf(I,J)), err_tempu) + tempv = SQRT(v_shlf(I,J)**2 + tempu**2) endif if (err_tempv >= err_max) then err_max = err_tempv @@ -1006,8 +1025,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) enddo enddo - u_last(:,:) = u(:,:) - v_last(:,:) = v(:,:) + u_last(:,:) = u_shlf(:,:) + v_last(:,:) = v_shlf(:,:) call max_across_PEs(max_vel) call max_across_PEs(err_max) @@ -1015,7 +1034,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) endif - write(mesg,*) "ice_shelf_solve_outer: nonlinear residual = ",err_max/err_init + write(mesg,*) "ice_shelf_solve_outer: nonlinear residual = ", err_max/err_init call MOM_mesg(mesg, 5) if (err_max <= CS%nonlinear_tolerance * err_init) then @@ -1031,20 +1050,22 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) end subroutine ice_shelf_solve_outer -subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_cond, & +subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & hmask, conv_flag, iters, time, Phi, Phisub) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u !< The zonal ice shelf velocity at vertices [m year-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v !< The meridional ice shelf velocity at vertices [m year-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudx !< The x-direction driving stress, in ??? + intent(in) :: taudx !< The x-direction driving stress, in [kg L s-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudy !< The y-direction driving stress, in ??? + intent(in) :: taudy !< The y-direction driving stress, in [kg L s-2 ~> kg m s-2] + ! This will become [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. @@ -1060,10 +1081,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c type(time_type), intent(in) :: Time !< The current model time real, dimension(SZDI_(G),SZDJ_(G),8,4), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies. + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] ! one linear solve (nonlinear iteration) of the solution for velocity ! in this subroutine: @@ -1074,18 +1095,24 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c ! assumed - u, v, taud, visc, beta_eff are valid on the halo real, dimension(SZDIB_(G),SZDJB_(G)) :: & - Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & - ubd, vbd, Au, Av, Du, Dv, & - Zu_old, Zv_old, Ru_old, Rv_old, & + Ru, Rv, & ! Residuals in the stress calculations [L kg s-2 ~> m kg s-2] + Ru_old, Rv_old, & + Zu, Zv, & ! Contributions to velocity changes [L yr-1 ~> m yr-1]? + Zu_old, Zv_old, & ! Previous values of Zu and Zv [L yr-1 ~> m yr-1]? + DIAGu, DIAGv, & + RHSu, RHSv, & ! Right hand side of the stress balance [L kg s-2 ~> m kg s-2] + ubd, vbd, & ! Boundary stress contributions [L kg s-2 ~> m kg s-2] + Au, Av, & + Du, Dv, & ! Velocity changes [L yr-1 ~> m yr-1] sum_vec, sum_vec_2 - integer :: iter, i, j, isd, ied, jsd, jed, & + integer :: iter, i, j, isd, ied, jsd, jed, & isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo - real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a - character(2) :: gridsize + real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a + real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] +! character(2) :: gridsize - real, dimension(8,4) :: Phi_temp - real, dimension(2,2) :: X,Y +! real, dimension(2,2) :: X,Y isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -1106,37 +1133,38 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB - call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) + call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + CS%density_ice/CS%density_ocean_avg, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - call matrix_diagonal(CS, G, float_cond, H_node, CS%ice_visc, & + call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, & CS%taub_beta_eff, hmask, & CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) ! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) - call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, & - G%US%L_to_m**2*G%areaT, G, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, US, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) + resid_scale = US%L_to_m**2 + if (.not. CS%use_reproducing_sums) then do j=jsumstart,jecq do i=isumstart,iecq - if (CS%umask(i,j) == 1) dot_p1 = dot_p1 + Ru(i,j)**2 - if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + Rv(i,j)**2 + if (CS%umask(i,j) == 1) dot_p1 = dot_p1 + resid_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + resid_scale*Rv(i,j)**2 enddo enddo @@ -1148,8 +1176,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsumstart,jecq do i=isumstart,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Rv(i,j)**2 enddo enddo @@ -1195,8 +1223,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c Au(:,:) = 0 ; Av(:,:) = 0 call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, & - G%US%L_to_m**2*G%areaT, G, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, US, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) ! Au, Av valid region moves in by 1 @@ -1208,12 +1236,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsumstart,jecq do i=isumstart,iecq if (CS%umask(i,j) == 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Du(i,j)*Au(i,j) + dot_p1 = dot_p1 + resid_scale*Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + resid_scale*Du(i,j)*Au(i,j) endif if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) + dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + resid_scale*Dv(i,j)*Av(i,j) endif enddo enddo @@ -1224,11 +1252,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jscq,jecq do i=iscq,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Zv(i,j) * Rv(i,j) + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Zv(i,j) * Rv(i,j) - if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) - if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + Dv(i,j) * Av(i,j) + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Du(i,j) * Au(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*Dv(i,j) * Av(i,j) enddo enddo @@ -1243,8 +1271,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsd,jed do i=isd,ied - if (CS%umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) - if (CS%vmask(i,j) == 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) + if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) + if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(i,j) enddo enddo @@ -1290,12 +1318,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsumstart,jecq do i=isumstart,iecq if (CS%umask(i,j) == 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) + dot_p1 = dot_p1 + resid_scale*Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + resid_scale*Zu_old(i,j)*Ru_old(i,j) endif if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) + dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + resid_scale*Zv_old(i,j)*Rv_old(i,j) endif enddo enddo @@ -1308,13 +1336,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsumstart,jecq do i=isumstart,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & - Zv(i,j) * Rv(i,j) + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Zv(i,j) * Rv(i,j) - if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) - if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & - Zv_old(i,j) * Rv_old(i,j) + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Zu_old(i,j) * Ru_old(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*Zv_old(i,j) * Rv_old(i,j) enddo enddo @@ -1349,10 +1375,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsumstart,jecq do i=isumstart,iecq if (CS%umask(i,j) == 1) then - dot_p1 = dot_p1 + Ru(i,j)**2 + dot_p1 = dot_p1 + resid_scale*Ru(i,j)**2 endif if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + Rv(i,j)**2 + dot_p1 = dot_p1 + resid_scale*Rv(i,j)**2 endif enddo enddo @@ -1364,8 +1390,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsumstart,jecq do i=isumstart,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Rv(i,j)**2 enddo enddo @@ -1386,7 +1412,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c if (cg_halo == 0) then ! pass vectors call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) cg_halo = 3 endif @@ -1396,20 +1422,20 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsdq,jedq do i=isdq,iedq if (CS%umask(i,j) == 3) then - u(i,j) = CS%u_bdry_val(i,j) + u_shlf(I,J) = CS%u_bdry_val(i,j) elseif (CS%umask(i,j) == 0) then - u(i,j) = 0 + u_shlf(I,J) = 0 endif if (CS%vmask(i,j) == 3) then - v(i,j) = CS%v_bdry_val(i,j) + v_shlf(I,J) = CS%v_bdry_val(i,j) elseif (CS%vmask(i,j) == 0) then - v(i,j) = 0 + v_shlf(I,J) = 0 endif enddo enddo - call pass_vector(u,v, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) if (conv_flag == 0) then iters = CS%cg_max_iterations @@ -1431,7 +1457,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl !! the zonal mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z m2 ~> m3]. + !! through the 4 cell boundaries [Z L2 ~> m3]. ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1455,8 +1481,9 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl integer :: i_off, j_off logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh + real :: u_face ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell + real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character (len=1) :: debug_str is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec @@ -1488,8 +1515,6 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*G%areaT(i,j) - h_after_uflux(i,j) = h0(i,j) stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 @@ -1500,7 +1525,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (CS%u_face_mask(i-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) / dxdyh + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) / G%areaT(i,j) else @@ -1514,32 +1539,32 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it stencil (-1) = CS%thickness_bdry_val(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid - phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j)* time_step / G%areaT(i,j) * & + (stencil(-1) - slope_lim * (stencil(-1)-stencil(0))/2) else ! h(i-1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i-2) is not - flux_diff_cell = flux_diff_cell + ABS(u_face) * (dyh * time_step / dxdyh) * stencil(-1) + flux_diff_cell = flux_diff_cell + ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(-1) endif elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * (dyh * time_step / dxdyh) * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(0) if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif endif @@ -1551,7 +1576,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (CS%u_face_mask(i+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) / dxdyh + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) / G%areaT(i,j) else @@ -1562,19 +1587,19 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid - phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + (stencil(1) - slope_lim * (stencil(1)-stencil(0))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell + ABS(u_face) * (dyh * time_step / dxdyh) * stencil(1) + flux_diff_cell = flux_diff_cell + ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(1) endif @@ -1582,18 +1607,18 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (stencil(0)-stencil(1))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell - ABS(u_face) * (dyh * time_step / dxdyh) * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(0) if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -1608,16 +1633,16 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter(i,j,1) = ABS(u_face) * G%US%L_to_m*G%dyT(i,j) * time_step * CS%thickness_bdry_val(i-1,j) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i-1,j) elseif (CS%u_face_mask(i-1,j) == 4.) then - flux_enter(i,j,1) = G%US%L_to_m*G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) endif if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%US%L_to_m*G%dyT(i,j) * time_step * CS%thickness_bdry_val(i+1,j) + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i+1,j) elseif (CS%u_face_mask(i+1,j) == 4.) then - flux_enter(i,j,2) = G%US%L_to_m*G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) endif if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -1662,7 +1687,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, !! the meridional mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z m2 ~> m3]. + !! through the 4 cell boundaries [Z L2 ~> m3]. ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1686,8 +1711,9 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, integer :: i_off, j_off logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell + real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character(len=1) :: debug_str is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1717,7 +1743,6 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, endif if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*G%areaT(i,j) h_after_vflux(i,j) = h_after_uflux(i,j) stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 @@ -1727,7 +1752,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (CS%v_face_mask(i,j-1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) / dxdyh + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) / G%areaT(i,j) else @@ -1740,31 +1765,32 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid - phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(-1) - slope_lim * (stencil(-1)-stencil(0))/2) else ! h(j-1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * (dxh * time_step / dxdyh) * stencil(-1) + flux_diff_cell = flux_diff_cell + ABS(v_face) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * stencil(-1) endif elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * (dxh * time_step / dxdyh) * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(v_face) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + !### The G%dyT in the next line needs to become G%dxCu(i,J-1) if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -1777,7 +1803,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (CS%v_face_mask(i,j+1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) / dxdyh + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) / G%areaT(i,j) else @@ -1788,29 +1814,29 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid - phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(1) - slope_lim * (stencil(1)-stencil(0))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(1) endif elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (stencil(0)-stencil(1))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) endif endif @@ -1824,16 +1850,16 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) - flux_enter(i,j,3) = ABS(v_face) * G%US%L_to_m*G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j-1) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j-1) elseif (CS%v_face_mask(i,j-1) == 4.) then - flux_enter(i,j,3) = G%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) endif if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) - flux_enter(i,j,4) = ABS(v_face) * G%US%L_to_m*G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j+1) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j+1) elseif (CS%v_face_mask(i,j+1) == 4.) then - flux_enter(i,j,4) = G%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) endif if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then @@ -1863,7 +1889,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z m2 ~> m3]. + !! through the 4 cell boundaries [Z L2 ~> m3]. ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary @@ -1896,17 +1922,18 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) integer :: i_off, j_off integer :: iter_flag - real :: h_reference, dxh, dyh, rho, tot_flux - real :: partial_vol ! The volume covered by ice shelf [m L2 ~> m3] + real :: h_reference ! A reference thicknesss based on neighboring cells [Z ~> m] + real :: tot_flux ! The total ice mass flux [Z L2 ~> m3] + real :: partial_vol ! The volume covered by ice shelf [Z L2 ~> m3] real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message integer, dimension(4) :: mapi, mapj, new_partial ! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace ! An updated ice volume flux into the + ! cell through the 4 cell boundaries [Z L2 ~> m3]. isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec i_off = G%idg_offset ; j_off = G%jdg_offset - rho = CS%density_ice iter_count = 0 ; iter_flag = 1 @@ -1961,23 +1988,23 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) if (n_flux > 0) then dxdyh = G%areaT(i,j) h_reference = h_reference / real(n_flux) - partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + G%US%m_to_L**2*tot_flux + partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux - if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow + if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow ISS%hmask(i,j) = 1 ISS%h_shelf(i,j) = h_reference - ISS%area_shelf_h(i,j) = dxdyh - elseif ((partial_vol / dxdyh) < h_reference) then + ISS%area_shelf_h(i,j) = G%areaT(i,j) + elseif ((partial_vol / G%areaT(i,j)) < h_reference) then ISS%hmask(i,j) = 2 - ! ISS%mass_shelf(i,j) = G%US%L_to_Z*G%US%L_to_m*partial_vol * G%US%kg_m3_to_R*rho + ! ISS%mass_shelf(i,j) = partial_vol * CS%density_ice ISS%area_shelf_h(i,j) = partial_vol / h_reference ISS%h_shelf(i,j) = h_reference else ISS%hmask(i,j) = 1 - ISS%area_shelf_h(i,j) = dxdyh + ISS%area_shelf_h(i,j) = G%areaT(i,j) !h_temp(i,j) = h_reference - partial_vol = partial_vol - h_reference * dxdyh + partial_vol = partial_vol - h_reference * G%areaT(i,j) iter_flag = 1 @@ -1999,15 +2026,15 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) enddo if (n_flux == 0) then ! there is nowhere to put the extra ice! - ISS%h_shelf(i,j) = h_reference + partial_vol / dxdyh + ISS%h_shelf(i,j) = h_reference + partial_vol / G%areaT(i,j) else ISS%h_shelf(i,j) = h_reference do k=1,2 if (new_partial(k) == 1) & - flux_enter_replace(i+2*k-3,j,3-k) = G%US%L_to_m**2*partial_vol / real(n_flux) + flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) if (new_partial(k+2) == 1) & - flux_enter_replace(i,j+2*k-3,5-k) = G%US%L_to_m**2*partial_vol / real(n_flux) + flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) enddo endif @@ -2080,25 +2107,26 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask -subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) +subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: TAUD_X !< X-direction driving stress at q-points + intent(inout) :: taud_x !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: TAUD_Y !< Y-direction driving stress at q-points + intent(inout) :: taud_y !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + ! This will become [R L3 Z T-2 ~> kg m s-2] ! driving stress! ! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. ! they will sit on the BGrid, and so their size depends on whether the grid is symmetric ! -! Since this is a finite element solve, they will actually have the form \int \phi_i rho g h \nabla s +! Since this is a finite element solve, they will actually have the form \int \Phi_i rho g h \nabla s ! ! OD -this is important and we do not yet know where (in MOM) it will come from. It represents ! "average" ocean depth -- and is needed to find surface elevation @@ -2108,7 +2136,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) BASE ! basal elevation of shelf/stream [Z ~> m]. - real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh, grav + real :: rho, rhow ! Ice and ocean densities [R ~> kg m-3] + real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> m s-1] + real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] + real :: dxh, dyh ! Local grid spacing [L ~> m] + real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: taud_scale ! The conversion factor from scaled to MKS units for taud_x and + ! taud_y [kg s-2 R-1 L-2 Z-1 T2 ~> 1] integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec @@ -2123,9 +2157,10 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset - rho = CS%density_ice + rho = CS%density_ice rhow = CS%density_ocean_avg - grav = US%Z_to_m**2 * CS%g_Earth + grav = CS%g_Earth + taud_scale = US%R_to_kg_m3*US%Z_to_m**US%L_T_to_m_s**2 ! prelim - go through and calculate S @@ -2138,9 +2173,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) cnt = 0 sx = 0 sy = 0 - dxh = US%L_to_m*G%dxT(i,j) - dyh = US%L_to_m*G%dyT(i,j) - dxdyh = US%L_to_m**2*G%areaT(i,j) + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell @@ -2213,20 +2247,20 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) endif ! SW vertex - taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh - taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! SE vertex - taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh - taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! NW vertex - taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh - taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! NE vertex - taud_x(I,J) = taud_x(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh - taud_y(I,J) = taud_y(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + taud_x(I,J) = taud_x(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I,J) = taud_y(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) if (CS%ground_frac(i,j) == 1) then neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) @@ -2234,7 +2268,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 endif - if ((CS%u_face_mask(i-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated @@ -2244,27 +2277,27 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation ! is not above the base of the ice in the current cell - ! note negative sign due to direction of normal vector - taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val - taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val + ! Note the negative sign due to the direction of the normal vector + taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * taud_scale * dyh * neumann_val + taud_x(i-1,j) = taud_x(i-1,j) - .5 * taud_scale * dyh * neumann_val endif if ((CS%u_face_mask(i,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then ! right face of the cell is at a stress boundary - taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val - taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val + taud_x(i,j-1) = taud_x(i,j-1) + .5 * taud_scale * dyh * neumann_val + taud_x(i,j) = taud_x(i,j) + .5 * taud_scale * dyh * neumann_val endif if ((CS%v_face_mask(i,j-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then ! south face of the cell is at a stress boundary - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val - taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val + taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * taud_scale * dxh * neumann_val + taud_y(i,j-1) = taud_y(i,j-1) - .5 * taud_scale * dxh * neumann_val endif if ((CS%v_face_mask(i,j) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then ! north face of the cell is at a stress boundary - taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign due to direction of normal vector - taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val + taud_y(i-1,j) = taud_y(i-1,j) + .5 * taud_scale * dxh * neumann_val + taud_y(i,j) = taud_y(i,j) + .5 * taud_scale * dxh * neumann_val endif endif @@ -2280,7 +2313,8 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, intent(in) :: input_flux !< The integrated inward ice thickness flux [Z m2 s-1 ~> m3 s-1] + real, intent(in) :: input_flux !< The integrated inward ice thickness flux per + !! unit face length [Z L s-1 ~> m2 s-1] real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted @@ -2325,6 +2359,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new endif endif + !### What about v_shelf? if (.not.(new_sim)) then if (.not. G%symmetric) then if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then @@ -2343,24 +2378,24 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new end subroutine init_boundary_values -subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & - nu, float_cond, bathyT, beta, dxdyh, G, is, ie, js, je, dens_ratio) +subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & + nu, float_cond, bathyT, beta, dxdyh, G, US, is, ie, js, je, dens_ratio) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: uret !< The retarding stresses working at u-points. + intent(inout) :: uret !< The retarding stresses working at u-points. [L ? ~> m ?] real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: vret !< The retarding stresses working at v-points. + intent(inout) :: vret !< The retarding stresses working at v-points. [L ? ~> m ?] real, dimension(SZDI_(G),SZDJ_(G),8,4), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies. + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: u !< The zonal ice shelf velocity at vertices [m year-1] + intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: v !< The meridional ice shelf velocity at vertices [m year-1] + intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point @@ -2376,7 +2411,7 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: nu !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the - !! basal law exponent. + !! basal law exponent. [?] real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2385,12 +2420,13 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: beta !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent. + !! units depend on the basal law exponent. [L-2 ? ~> m-2 ?] ! and/or whether flow is "hybridized" real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: dxdyh !< The tracer cell area [m2] + intent(in) :: dxdyh !< The tracer cell area [L2 ~> m2] real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors integer, intent(in) :: is !< The starting i-index to work on integer, intent(in) :: ie !< The ending i-index to work on integer, intent(in) :: js !< The starting j-index to work on @@ -2415,10 +2451,11 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, ! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q ! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear - real :: ux, vx, uy, vy, uq, vq, area, basel + real :: ux, vx, uy, vy, uq, vq, basel + real :: area integer :: iq, jq, iphi, jphi, i, j, ilq, jlq real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr ! ,Ucontr xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) @@ -2427,124 +2464,94 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, ! dxh = G%dxh(i,j) ! dyh = G%dyh(i,j) ! -! X(:,:) = G%geoLonBu(i-1:i,j-1:j) -! Y(:,:) = G%geoLatBu(i-1:i,j-1:j) +! X(:,:) = G%geoLonBu(i-1:i,j-1:j)*US%m_to_L +! Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*US%m_to_L ! -! call bilinear_shape_functions (X, Y, Phi, area) +! call bilinear_shape_functions(X, Y, Phi, area) ! X and Y must be passed in the form ! 3 - 4 ! | | ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j area = dxdyh(i,j) - Ucontr=0 + ! Ucontr=0 do iq=1,2 ; do jq=1,2 + uq = u_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + u_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & + u_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & + u_shlf(i,j) * xquad(iq) * xquad(jq) - if (iq == 2) then - ilq = 2 - else - ilq = 1 - endif + vq = v_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + v_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & + v_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & + v_shlf(i,j) * xquad(iq) * xquad(jq) - if (jq == 2) then - jlq = 2 - else - jlq = 1 - endif + ux = u_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + u_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + u_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + u_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) - uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u(i,j-1) * xquad(iq) * xquad(3-jq) + & - u(i-1,j) * xquad(3-iq) * xquad(jq) + & - u(i,j) * xquad(iq) * xquad(jq) + vx = v_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + v_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + v_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + v_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) - vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v(i,j-1) * xquad(iq) * xquad(3-jq) + & - v(i-1,j) * xquad(3-iq) * xquad(jq) + & - v(i,j) * xquad(iq) * xquad(jq) + uy = u_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + u_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + u_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + u_shlf(i,j) * Phi(i,j,8,2*(jq-1)+iq) - ux = u(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - vx = v(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - uy = u(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,8,2*(jq-1)+iq) - - vy = v(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,8,2*(jq-1)+iq) + vy = v_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + v_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + v_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + v_shlf(i,j) * Phi(i,j,8,2*(jq-1)+iq) do iphi=1,2 ; do jphi=1,2 if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & - .25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) endif if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & - .25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) endif - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif - if (float_cond(i,j) == 0) then + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) - + 0.25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) endif if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) - + 0.25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) endif endif - Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) enddo ; enddo enddo ; enddo if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = bathyT(i,j) - Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) + Ucell(:,:) = u_shlf(i-1:i,j-1:j) ; Vcell(:,:) = v_shlf(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, area, basel, & dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi=1,2 if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) endif if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) endif enddo ; enddo endif @@ -2557,21 +2564,23 @@ end subroutine CG_action subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. - real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [m year-1] - real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [m year-1] - real, intent(in) :: DXDYH !< The tracer cell area [m2] + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater, nondimensional + !! of seawater [nondim] real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction basal stress. + !! the u-direction basal stress [L3 yr-1 ~> m3 yr-1]. real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction basal stress. + !! the v-direction basal stress [L3 yr-1 ~> m3 yr-1]. - integer :: nsub, i, j, k, l, qx, qy, m, n - real :: subarea, hloc, uq, vq + real :: subarea ! A sub-cell area [L2 ~> m2] + real :: hloc ! The local sub-cell ice thickness [Z ~> m] + real :: uq, vq ! Local velocities [L yr-1 ~> m yr-1] + integer :: nsub, i, j, k, l, qx, qy, m, n nsub = size(Phisub,1) subarea = DXDYH / (nsub**2) @@ -2591,8 +2600,8 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, U uq = 0 ; vq = 0 do k=1,2 do l=1,2 - !Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) - !Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) + ! Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) + ! Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) enddo enddo @@ -2612,11 +2621,12 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, U end subroutine CG_action_subgrid_basal !> returns the diagonal entries of the matrix for a Jacobi preconditioning -subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, & +subroutine matrix_diagonal(CS, G, US, float_cond, H_node, nu, beta, hmask, dens_ratio, & Phisub, u_diagonal, v_diagonal) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2630,28 +2640,29 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: beta !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent + !! units depend on the basal law exponent [L-2 ? ~> m-2 ?] real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater, nondimensional + !! of seawater [nondim] real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity - !! matrix from the left-hand side of the solver. + !! matrix from the left-hand side of the solver [same units as nu]. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity - !! matrix from the left-hand side of the solver. + !! matrix from the left-hand side of the solver [same units as nu]. ! returns the diagonal entries of the matrix for a Jacobi preconditioning integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel - real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y + real :: A, n, ux, uy, vx, vy, eps_min, domain_width + real :: area, uq, vq, basel + real, dimension(8,4) :: Phi ! [L-1 ~> m-1] + real, dimension(4) :: X, Y ! Sub-cell positions [L ~> m] real, dimension(2) :: xquad real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr @@ -2664,19 +2675,15 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati ! 3 - 4 ! | | ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) - dyh = G%US%L_to_m*G%dyT(i,j) - dxdyh = G%US%L_to_m**2*G%areaT(i,j) - - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu(i-1:i,j) *1000 - Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000 - Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L + X(3:4) = G%geoLonBu(i-1:i,j) *1000.0*US%m_to_L + Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000.0*US%m_to_L + Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L call bilinear_shape_functions(X, Y, Phi, area) @@ -2684,8 +2691,8 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati ! 3 - 4 ! | | ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j do iq=1,2 ; do jq=1,2 @@ -2705,40 +2712,40 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) vx = 0. vy = 0. u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * G%areaT(i,j) * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) uq = xquad(ilq) * xquad(jlq) if (float_cond(i,j) == 0) then u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + 0.25 * beta(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then - vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) ux = 0. uy = 0. v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * G%areaT(i,j) * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) vq = xquad(ilq) * xquad(jlq) if (float_cond(i,j) == 0) then v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2747,7 +2754,7 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal(Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) + call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), basel, dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi=1,2 if (CS%umask(i-2+iphi,j-2+jphi) == 1) then u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) @@ -2762,22 +2769,23 @@ end subroutine matrix_diagonal subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - real, intent(in) :: DXDYH !< The tracer cell area [m2] + real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater, nondimensional + !! of seawater [nondim] real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction diagonal elements from basal stress. + !! the u-direction diagonal elements from basal stress [L2 ~> m2]. real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction diagonal elements from basal stress. + !! the v-direction diagonal elements from basal stress [L2 ~> m2]. ! bathyT = cellwise-constant bed elevation - integer :: nsub, i, j, k, l, qx, qy, m, n - real :: subarea, hloc + real :: subarea ! The local sub-region area [L2 ~> m2] + real :: hloc ! The local sub-region thickness [Z ~> m] + integer :: nsub, i, j, k, l, qx, qy, m, n nsub = size(Phisub,1) subarea = DXDYH / (nsub**2) @@ -2797,17 +2805,18 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, end subroutine CG_diagonal_subgrid_basal -subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & +subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, float_cond, & dens_ratio, u_bdry_contr, v_bdry_contr) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(time_type), intent(in) :: Time !< The current model time real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. @@ -2818,7 +2827,7 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: beta !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent + !! units depend on the basal law exponent [L-2 ~> m-2] real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2826,10 +2835,10 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo !! of seawater, nondimensional real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: u_bdry_contr !< Contributions to the zonal ice - !! velocities due to the open boundaries + !! velocities due to the open boundaries [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_bdry_contr !< Contributions to the zonal ice - !! velocities due to the open boundaries + !! velocities due to the open boundaries [L yr-1 ~> m yr-1] ! this will be a per-setup function. the boundary values of thickness and velocity ! (and possibly other variables) will be updated in this function @@ -2838,7 +2847,7 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo real, dimension(4) :: X, Y real, dimension(2) :: xquad integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel + real :: A, n, ux, uy, vx, vy, eps_min, domain_width, uq, vq, area, basel real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr @@ -2850,8 +2859,8 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo ! 3 - 4 ! | | ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then @@ -2861,14 +2870,10 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo if ((CS%umask(i-1,j-1) == 3) .OR. (CS%umask(i,j-1) == 3) .OR. & (CS%umask(i-1,j) == 3) .OR. (CS%umask(i,j) == 3)) then - dxh = G%US%L_to_m*G%dxT(i,j) - dyh = G%US%L_to_m*G%dyT(i,j) - dxdyh = G%US%L_to_m**2*G%areaT(i,j) - - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu(i-1:i,j)*1000 - Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000 - Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L + X(3:4) = G%geoLonBu(i-1:i,j)*1000.0*US%m_to_L + Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000.0*US%m_to_L + Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L call bilinear_shape_functions(X, Y, Phi, area) @@ -2876,38 +2881,38 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo ! 3 - 4 ! | | ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j do iq=1,2 ; do jq=1,2 uq = CS%u_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & CS%u_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & CS%u_bdry_val(i,j) * xquad(iq) * xquad(jq) vq = CS%v_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & CS%v_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & CS%v_bdry_val(i,j) * xquad(iq) * xquad(jq) ux = CS%u_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - CS%u_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & CS%u_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & CS%u_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) vx = CS%v_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - CS%v_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & CS%v_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & CS%v_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) uy = CS%u_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - CS%u_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & CS%u_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & CS%u_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) vy = CS%v_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - CS%v_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & CS%v_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & CS%v_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) @@ -2926,15 +2931,13 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo endif if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - - u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * G%areaT(i,j) * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + 0.25 * beta(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif @@ -2943,12 +2946,12 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * G%areaT(i,j) * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2956,19 +2959,19 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Usubcontr = 0.0 ; Vsubcontr = 0.0 Ucell(:,:) = CS%u_bdry_val(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_bdry_val(i-1:i,j-1:j) Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, dxdyh, basel, & + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), G%bathyT(i,j), & dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi = 1,2 if (CS%umask(i-2+iphi,j-2+jphi) == 1) then u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & - Usubcontr(iphi,jphi) * beta(i,j) + Usubcontr(iphi,jphi) * beta(i,j) endif if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & - Vsubcontr(iphi,jphi) * beta(i,j) + Vsubcontr(iphi,jphi) * beta(i,j) endif enddo ; enddo endif @@ -2979,16 +2982,16 @@ end subroutine apply_boundary_values !> Update depth integrated viscosity, based on horizontal strain rates, and also update the !! nonlinear part of the basal traction. -subroutine calc_shelf_visc(CS, ISS, G, US, u, v) +subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: u !< The zonal ice shelf velocity [m year-1]. + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L yr-1 ~> m yr-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v !< The meridional ice shelf velocity [m year-1]. + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L yr-1 ~> m yr-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve ! so there is an "upper" and "lower" bilinear viscosity @@ -2999,7 +3002,10 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u, v) integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh + real :: A, n + real :: ux, uy, vx, vy, eps_min ! Velocity shears [yr-1] + real :: umid, vmid, unorm ! Velocities [L yr-1 ~> m yr-1] + real :: n_basal_friction isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -3010,29 +3016,25 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u, v) is = iscq - 1; js = jscq - 1 A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction + n_basal_friction = CS%n_basal_friction do j=jsd+1,jed-1 do i=isd+1,ied-1 - dxh = US%L_to_m*G%dxT(i,j) - dyh = US%L_to_m*G%dyT(i,j) - dxdyh = US%L_to_m**2*G%areaT(i,j) - if (ISS%hmask(i,j) == 1) then - ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) - vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) - uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) - vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh) + ux = (u_shlf(i,j) + u_shlf(i,j-1) - u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dxT(i,j)) + vx = (v_shlf(i,j) + v_shlf(i,j-1) - v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dxT(i,j)) + uy = (u_shlf(i,j) - u_shlf(i,j-1) + u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dyT(i,j)) + vy = (v_shlf(i,j) - v_shlf(i,j-1) + v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dyT(i,j)) CS%ice_visc(i,j) = .5 * A**(-1/n) * & - (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * & + (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2) ** ((1-n)/(2*n)) * & US%Z_to_m*ISS%h_shelf(i,j) - umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 - vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) - CS%taub_beta_eff(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + umid = (u_shlf(i,j) + u_shlf(i,j-1) + u_shlf(i-1,j) + u_shlf(i-1,j-1))/4 + vmid = (v_shlf(i,j) + v_shlf(i,j-1) + v_shlf(i-1,j) + v_shlf(i-1,j-1))/4 + unorm = sqrt (umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) + CS%taub_beta_eff(i,j) = US%L_to_m**2*CS%C_basal_friction * (US%L_to_m*unorm)**(n_basal_friction-1) endif enddo enddo @@ -3042,17 +3044,17 @@ end subroutine calc_shelf_visc subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ocean_mass !< The mass per unit area of the ocean [kg m-2]. logical, intent(in) :: find_avg !< If true, find the average of OD and ffrac, and !! reset the underlying running sums to 0. integer :: isc, iec, jsc, jec, i, j - real :: I_rho_ocean + real :: I_rho_ocean ! A typical specific volume of the ocean [R-1 ~> m3 kg-1] real :: I_counter - I_rho_ocean = 1.0 / (US%Z_to_m*CS%density_ocean_avg) + I_rho_ocean = 1.0 / CS%density_ocean_avg isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -3111,11 +3113,11 @@ end subroutine update_OD_ffrac_uncoupled !! that are centered at the vertices of the cell. values are calculated at !! points of gaussian quadrature. subroutine bilinear_shape_functions (X, Y, Phi, area) - real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. - real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies. - real, intent(out) :: area !< The quadrilateral cell area [m2]. + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + real, intent(out) :: area !< The quadrilateral cell area [L2 ~> m2]. ! X and Y must be passed in the form ! 3 - 4 @@ -3127,16 +3129,17 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) ! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) ! (ordered in same way as vertices) ! -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j ! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear ! ! This should be a one-off; once per nonlinear solve? once per lifetime? ! ... will all cells have the same shape and dimension? - real, dimension(4) :: xquad, yquad + real, dimension(4) :: xquad, yquad ! [nondim] + real :: a,b,c,d ! Various lengths [L ~> m] + real :: xexp, yexp ! [nondim] integer :: node, qpoint, xnode, xq, ynode, yq - real :: a,b,c,d,e,f,xexp,yexp xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) @@ -3148,6 +3151,11 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + ! a = (X(2)-X(1)) * (1-yquad(qpoint)) + (X(4)-X(3)) * yquad(qpoint) ! d(x)/d(x*) + ! b = (Y(2)-Y(1)) * (1-yquad(qpoint)) + (Y(4)-Y(3)) * yquad(qpoint) ! d(y)/d(x*) + ! c = (X(3)-X(1)) * (1-xquad(qpoint)) + (X(4)-X(2)) * xquad(qpoint) ! d(x)/d(y*) + ! d = (Y(3)-Y(1)) * (1-xquad(qpoint)) + (Y(4)-Y(2)) * xquad(qpoint) ! d(y)/d(y*) + do node=1,4 xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) @@ -3164,8 +3172,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) xexp = xquad(qpoint) endif - Phi (2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) - Phi (2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) enddo enddo @@ -3178,8 +3186,8 @@ end subroutine bilinear_shape_functions subroutine bilinear_shape_functions_subgrid(Phisub, nsub) real, dimension(nsub,nsub,2,2,2,2), & intent(inout) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations - integer, intent(in) :: nsub !< The nubmer of subgridscale quadrature locations in each direction + !! locations for finite element calculations [nondim] + integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction ! this subroutine is a helper for interpolation of floatation condition ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is @@ -3346,12 +3354,12 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face !if (j_off+j == gjsc+1) then !bot boundary ! v_face_mask(i,j-1) = 0. - ! umask (i-1:i,j-1) = 0. - ! vmask (i-1:i,j-1) = 0. + ! umask(i-1:i,j-1) = 0. + ! vmask(i-1:i,j-1) = 0. !elseif (j_off+j == gjec) then !top boundary ! v_face_mask(i,j) = 0. - ! umask (i-1:i,j) = 0. - ! vmask (i-1:i,j) = 0. + ! umask(i-1:i,j) = 0. + ! vmask(i-1:i,j) = 0. !endif if (i < G%ied) then @@ -3469,7 +3477,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< The time step for this update [s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] @@ -3505,13 +3513,13 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell + ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, t_bd, Tsurf + real :: t_bd, Tsurf real :: spy ! The amount of time in a year [T ~> s] real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. - rho = CS%density_ice spy = 365. * 86400. * US%s_to_T ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later @@ -3619,7 +3627,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f !! the zonal mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z m2 ~> degC m3] + !! the cell through the 4 cell boundaries [degC Z L2 ~> degC m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -3643,8 +3651,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f integer :: i_off, j_off logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh + real :: u_face ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell, phi character (len=1) :: debug_str @@ -3677,8 +3685,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*G%areaT(i,j) - h_after_uflux(i,j) = h0(i,j) stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 @@ -3689,8 +3695,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (CS%u_face_mask(i-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) * & - CS%t_bdry_val(i-1,j) / dxdyh + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) * & + CS%t_bdry_val(i-1,j) / G%areaT(i,j) else ! get u-velocity at center of left face @@ -3702,32 +3708,32 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j)* time_step / G%areaT(i,j) * & (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) else ! h(i-1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i-2) is not - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(-1) endif elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif endif @@ -3739,8 +3745,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (CS%u_face_mask(i+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) *& - CS%t_bdry_val(i+1,j)/ dxdyh + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) *& + CS%t_bdry_val(i+1,j) / G%areaT(i,j) else u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) @@ -3750,19 +3756,19 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & (stencil(1) - phi * (stencil(1)-stencil(0))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(1) endif @@ -3771,18 +3777,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(1))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -3797,18 +3803,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter(i,j,1) = ABS(u_face) * G%US%L_to_m*G%dyT(i,j) * time_step * CS%t_bdry_val(i-1,j)* & + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i-1,j) * & CS%thickness_bdry_val(i+1,j) elseif (CS%u_face_mask(i-1,j) == 4.) then - flux_enter(i,j,1) = G%US%L_to_m*G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j)*CS%t_bdry_val(i-1,j) + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j)*CS%t_bdry_val(i-1,j) endif if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%US%L_to_m*G%dyT(i,j) * time_step * CS%t_bdry_val(i+1,j)* & + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i+1,j)* & CS%thickness_bdry_val(i+1,j) elseif (CS%u_face_mask(i+1,j) == 4.) then - flux_enter(i,j,2) = G%US%L_to_m*G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) * CS%t_bdry_val(i+1,j) + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) * CS%t_bdry_val(i+1,j) endif ! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -3851,7 +3857,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft !! the meridional mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z m2 ~> degC m3] + !! the cell through the 4 cell boundaries [degC Z L2 ~> degC m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -3875,8 +3881,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft integer :: i_off, j_off logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell, phi character(len=1) :: debug_str is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3905,7 +3911,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft endif if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*G%areaT(i,j) h_after_vflux(i,j) = h_after_uflux(i,j) stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 @@ -3915,8 +3920,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (CS%v_face_mask(i,j-1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) * & - CS%t_bdry_val(i,j-1)/ dxdyh + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) * & + CS%t_bdry_val(i,j-1)/ G%areaT(i,j) else ! get u-velocity at center of left face @@ -3928,31 +3933,32 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) else ! h(j-1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(-1) endif elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + !### The G%dyT(i,j) below needs to be G%dxCv(i,J) if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -3965,8 +3971,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (CS%v_face_mask(i,j+1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) *& - CS%t_bdry_val(i,j+1)/ dxdyh + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) *& + CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else ! get u-velocity at center of right face @@ -3976,29 +3982,29 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (stencil(1) - phi * (stencil(1)-stencil(0))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(1) endif elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(1))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) endif endif @@ -4012,18 +4018,18 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - flux_enter(i,j,3) = ABS(v_face) * G%US%L_to_m*G%dxT(i,j) * time_step * CS%t_bdry_val(i,j-1)* & + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j-1)* & CS%thickness_bdry_val(i,j-1) elseif (CS%v_face_mask(i,j-1) == 4.) then - flux_enter(i,j,3) = G%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1)*CS%t_bdry_val(i,j-1) + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1)*CS%t_bdry_val(i,j-1) endif if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - flux_enter(i,j,4) = ABS(v_face) * G%US%L_to_m*G%dxT(i,j) * time_step * CS%t_bdry_val(i,j+1)* & + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j+1)* & CS%thickness_bdry_val(i,j+1) elseif (CS%v_face_mask(i,j+1) == 4.) then - flux_enter(i,j,4) = G%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1)*CS%t_bdry_val(i,j+1) + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1)*CS%t_bdry_val(i,j+1) endif ! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 16eb923fd4..f34b3c70f4 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -240,30 +240,31 @@ end subroutine initialize_ice_thickness_channel !BEGIN MJH ! subroutine initialize_ice_shelf_boundary(u_face_mask_bdry, v_face_mask_bdry, & ! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & -! hmask, G, PF ) +! hmask, G, US, PF ) ! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through - !! C-grid u faces [m2 s-1]. +! !! C-grid u faces [L Z s-1 ~> m2 s-1]. ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through - !! C-grid v faces [m2 s-1]. +! !! C-grid v faces [L Z s-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [m yr-1]. +! !! boundary vertices [m yr-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - !! boundary vertices [m yr-1]. +! !! boundary vertices [m yr-1]. ! real, dimension(SZDI_(G),SZDJ_(G)), & ! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries ! real, dimension(SZDI_(G),SZDJ_(G)), & ! intent(inout) :: hmask !< A mask indicating which tracer points are ! !! partly or fully covered by an ice-shelf +! type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors ! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary" ! This subroutine's name. @@ -296,19 +297,19 @@ end subroutine initialize_ice_thickness_channel ! subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & ! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & -! hmask, G, flux_bdry, PF ) +! hmask, G, flux_bdry, US, PF ) ! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through - !! C-grid u faces [m2 s-1]. +! !! C-grid u faces [L Z s-1 ~> m2 s-1]. ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through - !! C-grid v faces [m2 s-1]. +! !! C-grid v faces [L Z s-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open !! boundary vertices [m yr-1]. @@ -321,17 +322,20 @@ end subroutine initialize_ice_thickness_channel ! intent(inout) :: hmask !< A mask indicating which tracer points are ! !! partly or fully covered by an ice-shelf ! logical, intent(in) :: flux_bdry !< If true, use mass fluxes as the boundary value. +! type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors ! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. ! integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, ied, jed -! real :: lenlat, input_thick, input_flux, len_stress +! real :: input_thick +! real :: input_flux ! The input ice flux per unit length [L Z t-1 ~> m2 s-1] +! real :: lenlat, len_stress ! call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) ! call get_param(PF, mdl, "INPUT_FLUX_ICE_SHELF", input_flux, & ! "volume flux at upstream boundary", & -! units="m2 s-1", default=0.) +! units="m2 s-1", default=0., scale=US%m_to_L*US%m_to_Z) ! call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & ! "flux thickness at upstream boundary", & ! units="m", default=1000.) From 3d05d853775e1a8cfb9a99128b4b46da2897b850 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 24 Mar 2020 16:06:12 -0600 Subject: [PATCH 113/137] 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 114/137] 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 115/137] 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 d77c80319818184198b747df143afccd043f8131 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 25 Mar 2020 21:23:29 -0400 Subject: [PATCH 116/137] +Rescaled velocities in MOM_ice_shelf_dynamics.F90 Change the internal units of the ice shelf velocities from [L yr-1] to [m s-1] although diagnostics are still available in [L yr-1]. Also added dimensional rescaling of velocities and timesteps, along with other simplifying code changes in MOM_ice_shelf_dynamics.F90. Some unused code blocks were eliminated altogether and the new subroutine bilinear_shape_fn_grid was added to set up the finite element structure variables from MOM6's grid type, instead of making the assumption that a Cartesian grid is used with axes labeled in km. Also added comments describing many of the variables and their units. All answers are bitwise identical in the MOM6-examples test cases, but there are substantial changes to the MOM_ice_shelf_dynamics.F90 code and it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf.F90 | 13 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1181 ++++++++------------ src/ice_shelf/MOM_ice_shelf_initialize.F90 | 28 +- 3 files changed, 504 insertions(+), 718 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 8299d954b2..cd3ba3fd44 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -665,7 +665,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it - call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & + call update_ice_shelf(CS%dCS, ISS, G, US, US%s_to_T*time_step, Time, & US%kg_m3_to_R*US%m_to_Z*state%ocean_mass(:,:), coupled_GL) endif @@ -1786,9 +1786,9 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) +subroutine solo_time_step(CS, time_interval, nsteps, Time, min_time_step_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step !< The time interval for this update [s]. + real, intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. type(time_type), intent(inout) :: Time !< The current model time real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [s]. @@ -1799,6 +1799,7 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state integer :: is, iec, js, jec, i, j + real :: time_step real :: time_step_remain real :: time_step_int, min_time_step character(len=240) :: mesg @@ -1811,6 +1812,8 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) ISS => CS%ISS is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec + time_step = time_interval + time_step_remain = time_step if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -1825,7 +1828,7 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) nsteps = nsteps+1 ! If time_step is not too long, this is unnecessary. - time_step_int = min(ice_time_step_CFL(CS%dCS, ISS, G), time_step) + time_step_int = min(US%T_to_s*ice_time_step_CFL(CS%dCS, ISS, G), time_step) write (mesg,*) "Ice model timestep = ", time_step_int, " seconds" if (time_step_int < min_time_step) then @@ -1846,7 +1849,7 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) update_ice_vel = ((time_step_int > min_time_step) .or. (time_step_int >= time_step)) coupled_GL = .false. - call update_ice_shelf(CS%dCS, ISS, G, US, time_step_int, Time, must_update_vel=update_ice_vel) + call update_ice_shelf(CS%dCS, ISS, G, US, US%s_to_T*time_step_int, Time, must_update_vel=update_ice_vel) call enable_averaging(time_step,Time,CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 0fc319c621..908e79896a 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -8,7 +8,7 @@ module MOM_ice_shelf_dynamics use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid -use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averages, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe @@ -39,10 +39,10 @@ module MOM_ice_shelf_dynamics !> The control structure for the ice shelf dynamics. type, public :: ice_shelf_dyn_CS ; private - real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal (?) velocity of the ice shelf/sheet - !! on q-points (B grid) [L yr-1 ~> m yr-1] + real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal velocity of the ice shelf/sheet + !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet - !! on q-points (B grid) [L yr-1 ~> m yr-1] + !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, @@ -57,9 +57,9 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell - !! through open boundary u-faces (where u_face_mask=4) [Z L s-1 ~> m2 s-1] + !! through open boundary u-faces (where u_face_mask=4) [Z L T-1 ~> m2 s-1] real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell - !! through open boundary v-faces (where v_face_mask=4) [Z L s-1 ~> m2 s-1]?? + !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]?? ! needed where u_face_mask is equal to 4, similary for v_face_mask real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) !! 1=normal node, 3=inhomogeneous boundary node, @@ -81,7 +81,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. - real, pointer, dimension(:,:) :: taub_beta_eff => NULL() !< nonlinear part of "linearized" basal stress. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< nonlinear part of "linearized" basal stress. !! [L-2 ? ~> m-2 ?] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 @@ -94,12 +94,12 @@ module MOM_ice_shelf_dynamics integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity - !! using the nonlinear elliptic equation, or 0 to update every timestep [s]. + !! using the nonlinear elliptic equation, or 0 to update every timestep [T ~> s]. ! DNGoldberg thinks this should be done no more often than about once a day ! (maybe longer) because it will depend on ocean values that are averaged over ! this time interval, and solving for the equiliabrated flow will begin to lose ! meaning if it is done too frequently. - real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last udated [s]. + real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last updated [T ~> s]. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. @@ -119,12 +119,12 @@ module MOM_ice_shelf_dynamics real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs !! i.e. dt <= CFL_factor * min(dx / u) - real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-1/3 year]. + real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-3 s-1]. real :: n_glen !< Nonlinearity exponent in Glen's Law real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. - real :: C_basal_friction !< Ceofficient in sliding law tau_b = C u^(n_basal_friction), in - !! units="Pa (m-a)-(n_basal_friction) - real :: n_basal_friction !< Exponent in sliding law tau_b = C u^(m_slide) + real :: C_basal_friction !< Coefficient in sliding law tau_b = C u^(n_basal_fric), in + !! units= Pa (m yr-1)-(n_basal_fric) + real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the !! gravitational driving force at the shelf front (until we think of @@ -140,8 +140,7 @@ module MOM_ice_shelf_dynamics !! that sets when to stop the iterative velocity solver integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual - !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm - logical :: use_reproducing_sums !< Use reproducing global sums. + !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm ! ids for outputting intermediate thickness in advection subroutine (debugging) !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 @@ -240,7 +239,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 - allocate( CS%taub_beta_eff(isd:ied,jsd:jed) ) ; CS%taub_beta_eff(:,:) = 0.0 + allocate( CS%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 allocate( CS%ground_frac(isd:ied,jsd:jed) ) ; CS%ground_frac(:,:) = 0.0 @@ -257,7 +256,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) "fractional degree of grounding", "nondim") call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & "Glens law ice viscosity", "m (seems wrong)") - call register_restart_field(CS%taub_beta_eff, "tau_b_beta", .true., restart_CS, & + call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & "Coefficient of basal traction", "m (seems wrong)") endif @@ -282,8 +281,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Local variables real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. - real :: L_rescale ! A rescaling factor for horizontal lenghts from the representation in - ! a restart file to the internal representation in this run. + real :: vel_rescale ! A rescaling factor for horizontal velocities from the representation + ! in a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" character(len=200) :: config @@ -352,7 +351,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="kg m-3", default=1035., scale=US%kg_m3_to_R) if (active_shelf_dynamics) then call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & - "seconds between ice velocity calcs", units="s", & + "seconds between ice velocity calcs", units="s", scale=US%s_to_T, & fail_if_missing=.true.) call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & @@ -360,19 +359,21 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & "Ice viscosity parameter in Glen's Law", & - units="Pa -1/3 a", default=9.461e-18) + units="Pa-3 yr-1", default=9.461e-18, scale=1.0/(365.0*86400.0)) + ! This default is equivalent to 3.0001e-25 Pa-3 s-1, appropriate at about -10 C. call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & "nonlinearity exponent in Glen's Law", & units="none", default=3.) call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & "min. strain rate to avoid infinite Glen's law viscosity", & - units="a-1", default=1.e-12) - call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & - "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", & - units="Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.) - call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_friction, & - "exponent in sliding law \tau_b = C u^(m_slide)", & + units="a-1", default=1.e-12, scale=US%T_to_s/(365.0*86400.0)) + call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & + "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & + "Coefficient in sliding law \tau_b = C u^(n_basal_fric)", & + units="Pa (m yr-1)-(n_basal_fric)", scale=US%kg_m2s_to_RZ_T*((365.0*86400.0)**CS%n_basal_fric), & + fail_if_missing=.true.) call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -388,9 +389,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & "Choose whether nonlin error in vel solve is based on nonlinear "//& "residual (1) or relative change since last iteration (2)", default=1) - call get_param(param_file, mdl, "SHELF_DYN_REPRODUCING_SUMS", CS%use_reproducing_sums, & - "If true, use the reproducing extended-fixed-point sums in "//& - "the ice shelf dynamics solvers.", default=.true.) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & @@ -447,11 +445,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo endif - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then - L_rescale = US%m_to_L / US%m_to_L_restart + if ((US%m_to_L_restart*US%s_to_T_restart /= 0.0) .and. & + (US%m_to_L_restart /= US%m_s_to_L_T*US%s_to_T_restart)) then + vel_rescale = US%m_s_to_L_T*US%s_to_T_restart / US%m_to_L_restart do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec - CS%u_shelf(I,J) = L_rescale * CS%u_shelf(I,J) - CS%v_shelf(I,J) = L_rescale * CS%v_shelf(I,J) + CS%u_shelf(I,J) = vel_rescale * CS%u_shelf(I,J) + CS%v_shelf(I,J) = vel_rescale * CS%v_shelf(I,J) enddo ; enddo endif @@ -477,7 +476,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%OD_av,G%domain) call pass_var(CS%ground_frac,G%domain) call pass_var(CS%ice_visc,G%domain) - call pass_var(CS%taub_beta_eff,G%domain) + call pass_var(CS%basal_traction, G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) endif @@ -520,9 +519,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Register diagnostics. CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1, Time, & - 'x-velocity of ice', 'm yr-1', conversion=US%L_to_m) + 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & - 'y-velocity of ice', 'm yr-1', conversion=US%L_to_m) + 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1, Time, & @@ -561,7 +560,8 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) type(time_type), intent(in) :: Time !< The current model time integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi_rhow, OD + real :: rhoi_rhow + real :: OD ! Depth of open water below the ice shelf [Z ~> m] type(time_type) :: dummy_time rhoi_rhow = CS%density_ice / CS%density_ocean_avg @@ -586,37 +586,34 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) end subroutine initialize_diagnostic_fields -!> This function returns the global maximum timestep that can be taken based on the current +!> This function returns the global maximum advective timestep that can be taken based on the current !! ice velocities. Because it involves finding a global minimum, it can be suprisingly expensive. function ice_time_step_CFL(CS, ISS, G) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - real :: ice_time_step_CFL !< The maximum permitted timestep based on the ice velocities [s]. + real :: ice_time_step_CFL !< The maximum permitted timestep based on the ice velocities [T ~> s]. - real :: ratio, min_ratio ! These should be the minimum stable timesteps at a CFL of 1 [years] - real :: local_u_max, local_v_max ! The largest neighboring velocities [L yr-1 ~> m yr-1] + real :: dt_local, min_dt ! These should be the minimum stable timesteps at a CFL of 1 [T ~> s] + real :: min_vel ! A minimal velocity for estimating a timestep [L T-1 ~> m s-1] integer :: i, j - min_ratio = 1.0e16 ! This is just an arbitrary large nondimensional value. + min_dt = 5.0e17*G%US%s_to_T ! The starting maximum is roughly the lifetime of the universe. + min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then - local_u_max = max(abs(CS%u_shelf(i,j)), abs(CS%u_shelf(i+1,j+1)), & - abs(CS%u_shelf(i+1,j)), abs(CS%u_shelf(i,j+1))) - local_v_max = max(abs(CS%v_shelf(i,j)), abs(CS%v_shelf(i+1,j+1)), & - abs(CS%v_shelf(i+1,j)), abs(CS%v_shelf(i,j+1))) - - ! Here the hard-coded 1e-12 has units of m year-1. Consider revising. - !### Ratio should be a timestep in {s] or [yr], but this expression appears to be in [m yr] - ratio = G%US%L_to_m*min(G%areaT(i,j) / (local_u_max + 1.0e-12*G%US%m_to_L), & - G%areaT(i,j) / (local_v_max + 1.0e-12*G%US%m_to_L)) - min_ratio = min(min_ratio, ratio) + dt_local = 2.0*G%areaT(i,j) / & + ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & + G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & + (G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel) + & + G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel))) + + min_dt = min(min_dt, dt_local) endif ; enddo ; enddo ! i- and j- loops - call min_across_PEs(min_ratio) + call min_across_PEs(min_dt) - ! solved velocities are in m/yr; we want time_step_int in seconds - ice_time_step_CFL = CS%CFL_factor * min_ratio * (365*86400) + ice_time_step_CFL = CS%CFL_factor * min_dt end function ice_time_step_CFL @@ -628,7 +625,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, intent(in) :: time_step !< time step [s] + real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time real, dimension(SZDI_(G),SZDJ_(G)), & optional, intent(in) :: ocean_mass !< If present this is the mass per unit area @@ -663,7 +660,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) if (update_ice_vel) then - call enable_averaging(CS%elapsed_velocity_time, Time, CS%diag) + call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) @@ -690,7 +687,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - real, intent(in) :: time_step !< time step [s] + real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time @@ -729,9 +726,6 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: spy - - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -745,16 +739,16 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) endif ; enddo ; enddo - call ice_shelf_advect_thickness_x(CS, G, time_step/spy, ISS%hmask, ISS%h_shelf, h_after_uflux, flux_enter) + call ice_shelf_advect_thickness_x(CS, G, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, flux_enter) -! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var(h_after_uflux, G%domain) +! call enable_averages(time_step, Time, CS%diag) +! call pass_var(h_after_uflux, G%domain) ! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) ! call disable_averaging(CS%diag) - call ice_shelf_advect_thickness_y(CS, G, time_step/spy, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) + call ice_shelf_advect_thickness_y(CS, G, time_step, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) -! call enable_averaging(time_step,Time,CS%diag) +! call enable_averages(time_step, Time, CS%diag) ! call pass_var(h_after_vflux, G%domain) ! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) @@ -776,11 +770,11 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) endif endif - !call enable_averaging(time_step,Time,CS%diag) + !call enable_averages(time_step, Time, CS%diag) !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) !call disable_averaging(CS%diag) - !call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice) + !call change_thickness_using_melt(ISS, G, US%T_to_s*time_step, fluxes, CS%density_ice) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) @@ -793,32 +787,32 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY ! Driving stresses at q-points [kg L s-2 ~> kg m s-2] - ! The units should be [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont, v_bdry_cont ! Boundary velocity contributions [L yr-1 ~> m yr-1] - real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! A term in the momentum balance [L ? ~> m ?] + real, dimension(SZDIB_(G),SZDJB_(G)) :: taudx, taudy ! Driving stresses at q-points [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L yr-1 ~> m yr-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter - integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi_rhow + integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub + real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv + real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding the cell verticies [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] real, dimension(8,4) :: Phi_temp ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding a cell vertex [L-1 ~> m-1]. - real, dimension(2,2) :: X, Y ! Positions on cell [L ~> m] character(2) :: iternum character(2) :: numproc @@ -829,7 +823,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed rhoi_rhow = CS%density_ice / CS%density_ocean_avg - TAUDX(:,:) = 0.0 ; TAUDY(:,:) = 0.0 + taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 Au(:,:) = 0.0 ; Av(:,:) = 0.0 @@ -837,15 +831,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 allocate(Phisub(nsub,nsub,2,2,2,2)) ; Phisub(:,:,:,:,:,:) = 0.0 - isumstart = G%isc - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB - - jsumstart = G%jsc - ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB - - call calc_shelf_driving_stress(CS, ISS, G, US, TAUDX, TAUDY, CS%OD_av) + call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) ! this is to determine which cells contain the grounding line, ! the criterion being that the cell is ice-covered, with some nodes @@ -859,23 +845,20 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) - do j=G%jsc,G%jec - do i=G%isc,G%iec - nodefloat = 0 - do k=0,1 - do l=0,1 - if ((ISS%hmask(i,j) == 1) .and. & - (rhoi_rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) <= 0)) then - nodefloat = nodefloat + 1 - endif - enddo - enddo - if ((nodefloat > 0) .and. (nodefloat < 4)) then - float_cond(i,j) = 1.0 - CS%ground_frac(i,j) = 1.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + nodefloat = 0 + + do l=0,1 ; do k=0,1 + if ((ISS%hmask(i,j) == 1) .and. & + (rhoi_rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) <= 0)) then + nodefloat = nodefloat + 1 endif - enddo - enddo + enddo ; enddo + if ((nodefloat > 0) .and. (nodefloat < 4)) then + float_cond(i,j) = 1.0 + CS%ground_frac(i,j) = 1.0 + endif + enddo ; enddo call pass_var(float_cond, G%Domain) @@ -883,65 +866,49 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) endif - ! make above conditional - ! must prepare Phi allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:) = 0.0 do j=jsd,jed ; do i=isd,ied - if (((i > isd) .and. (j > jsd))) then - X(:,:) = G%geoLonBu(i-1:i,j-1:j)*1000.0*US%m_to_L - Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000.0*US%m_to_L - else - X(2,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L - X(1,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L - G%dxT(i,j) - Y(:,2) = G%geoLatBu(i,j)*1000.0*US%m_to_L - Y(:,1) = G%geoLatBu(i,j)*1000.0*US%m_to_L - G%dyT(i,j) - endif - - call bilinear_shape_functions(X, Y, Phi_temp, area) + call bilinear_shape_fn_grid(G, i, j, Phi_temp) Phi(i,j,:,:) = Phi_temp enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) - call pass_var(CS%taub_beta_eff, G%domain) + call pass_var(CS%basal_traction, G%domain) ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - err_init = 0 ; err_tempu = 0; err_tempv = 0 - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) == 1) then - err_tempu = ABS(Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + if (CS%nonlin_solve_err_mode == 1) then + err_init = 0 ; err_tempu = 0 ; err_tempv = 0 + do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + if (err_tempu >= err_init) err_init = err_tempu endif if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS(Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv >= err_init) then - err_init = err_tempv + err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + if (err_tempv >= err_init) err_init = err_tempv endif - enddo - enddo - - call max_across_PEs(err_init) + enddo ; enddo - write(mesg,*) "ice_shelf_solve_outer: INITIAL nonlinear residual = ", err_init*US%L_to_m - call MOM_mesg(mesg, 5) + call max_across_PEs(err_init) + endif u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) @@ -949,12 +916,12 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) do iter=1,100 - call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, TAUDX, TAUDY, H_node, float_cond, & + call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & ISS%hmask, conv_flag, iters, time, Phi, Phisub) if (CS%debug) then - call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_to_m) - call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_to_m) + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) endif write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" @@ -962,68 +929,61 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) - call pass_var(CS%taub_beta_eff, G%domain) + call pass_var(CS%basal_traction, G%domain) ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, & + CS%basal_traction, float_cond, & rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) err_max = 0 if (CS%nonlin_solve_err_mode == 1) then - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) == 1) then - err_tempu = ABS(Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) - endif - if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS(Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv >= err_max) then - err_max = err_tempv - endif - enddo - enddo + do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + if (err_tempu >= err_max) err_max = err_tempu + endif + if (CS%vmask(I,J) == 1) then + err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + if (err_tempv >= err_max) err_max = err_tempv + endif + enddo ; enddo call max_across_PEs(err_max) elseif (CS%nonlin_solve_err_mode == 2) then max_vel = 0 ; tempu = 0 ; tempv = 0 - - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) == 1) then - err_tempu = ABS(u_last(i,j)-u_shlf(I,J)) - tempu = u_shlf(I,J) - endif - if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS(v_last(i,j)-v_shlf(I,J)), err_tempu) - tempv = SQRT(v_shlf(I,J)**2 + tempu**2) - endif - if (err_tempv >= err_max) then - err_max = err_tempv - endif - if (tempv >= max_vel) then - max_vel = tempv - endif - enddo - enddo + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) + if (err_tempu >= err_max) err_max = err_tempu + tempu = u_shlf(I,J) + else + tempu = 0.0 + endif + if (CS%vmask(I,J) == 1) then + err_tempv = MAX(ABS(v_last(I,J)-v_shlf(I,J)), err_tempu) + if (err_tempv >= err_max) err_max = err_tempv + tempv = SQRT(v_shlf(I,J)**2 + tempu**2) + endif + if (tempv >= max_vel) max_vel = tempv + enddo ; enddo u_last(:,:) = u_shlf(:,:) v_last(:,:) = v_shlf(:,:) @@ -1031,10 +991,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call max_across_PEs(max_vel) call max_across_PEs(err_max) err_init = max_vel - endif - write(mesg,*) "ice_shelf_solve_outer: nonlinear residual = ", err_max/err_init + write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init call MOM_mesg(mesg, 5) if (err_max <= CS%nonlinear_tolerance * err_init) then @@ -1058,14 +1017,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudx !< The x-direction driving stress, in [kg L s-2 ~> kg m s-2] + intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudy !< The y-direction driving stress, in [kg L s-2 ~> kg m s-2] - ! This will become [R L3 Z T-2 ~> kg m s-2] + intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. @@ -1092,27 +1050,30 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! diagonal of matrix is found (for Jacobi precondition) ! CG iteration is carried out for max. iterations or until convergence -! assumed - u, v, taud, visc, beta_eff are valid on the halo +! assumed - u, v, taud, visc, basal_traction are valid on the halo real, dimension(SZDIB_(G),SZDJB_(G)) :: & - Ru, Rv, & ! Residuals in the stress calculations [L kg s-2 ~> m kg s-2] - Ru_old, Rv_old, & - Zu, Zv, & ! Contributions to velocity changes [L yr-1 ~> m yr-1]? - Zu_old, Zv_old, & ! Previous values of Zu and Zv [L yr-1 ~> m yr-1]? - DIAGu, DIAGv, & - RHSu, RHSv, & ! Right hand side of the stress balance [L kg s-2 ~> m kg s-2] - ubd, vbd, & ! Boundary stress contributions [L kg s-2 ~> m kg s-2] - Au, Av, & - Du, Dv, & ! Velocity changes [L yr-1 ~> m yr-1] + Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] + Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] + Zu, Zv, & ! Contributions to velocity changes [L T-1 ~> m s-1] + Zu_old, Zv_old, & ! Previous values of Zu and Zv [L T-1 ~> m s-1] + DIAGu, DIAGv, & ! Diagonals with units like Ru/Zu [R L2 Z T-1 ~> kg s-1] + RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] + ubd, vbd, & ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] + Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] + Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] sum_vec, sum_vec_2 - integer :: iter, i, j, isd, ied, jsd, jed, & - isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & - isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo - real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a + real :: tol, beta_k, area, dot_p1, resid0, cg_halo + real :: num, denom + real :: alpha_k ! A scaling factor for iterative corrections [nondim] real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] -! character(2) :: gridsize - -! real, dimension(2,2) :: X,Y + ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] + real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals + ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] + real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] + integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je + integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. + integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -1120,73 +1081,58 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 - dot_p1 = 0 ; dot_p2 = 0 + dot_p1 = 0 - isumstart = G%isc + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + Is_sum = G%isc + (1-G%IsdB) + Ie_sum = G%iecB + (1-G%IsdB) ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB + if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) - jsumstart = G%jsc + Js_sum = G%jsc + (1-G%JsdB) + Je_sum = G%jecB + (1-G%JsdB) ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) + CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, & - CS%taub_beta_eff, hmask, & - CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) -! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 + call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & + hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & - G%areaT, G, US, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) + H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & + G%areaT, G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) - - resid_scale = US%L_to_m**2 - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) dot_p1 = dot_p1 + resid_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + resid_scale*Rv(i,j)**2 - enddo - enddo - - call sum_across_PEs(dot_p1) - - else + Ru(:,:) = (RHSu(:,:) - Au(:,:)) + Rv(:,:) = (RHSv(:,:) - Av(:,:)) - sum_vec(:,:) = 0.0 + resid_scale = US%L_to_m**2*US%s_to_T*US%RZ_to_kg_m2*US%L_T_to_m_s**2 + resid2_scale = (US%RZ_to_kg_m2*US%L_to_m*US%L_T_to_m_s**2)**2 - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Rv(i,j)**2 - enddo - enddo + sum_vec(:,:) = 0.0 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*Rv(i,j)**2 + enddo ; enddo - dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & - jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + dot_p1 = reproducing_sum( sum_vec, Js_sum, Ie_sum, Js_sum, Je_sum ) - endif - - resid0 = sqrt (dot_p1) + resid0 = sqrt(dot_p1) do j=jsdq,jedq do i=isdq,iedq @@ -1206,8 +1152,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! !! !!!!!!!!!!!!!!!!!! - - ! initially, c-grid data is valid up to 3 halo nodes out do iter = 1,CS%cg_max_iterations @@ -1223,69 +1167,42 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Au(:,:) = 0 ; Av(:,:) = 0 call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & - G%areaT, G, US, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) + H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & + G%areaT, G, US, is, ie, js, je, rhoi_rhow) ! Au, Av valid region moves in by 1 - if ( .not. CS%use_reproducing_sums) then - - - ! alpha_k = (Z \dot R) / (D \dot AD} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + resid_scale*Du(i,j)*Au(i,j) - endif - if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + resid_scale*Dv(i,j)*Av(i,j) - endif - enddo - enddo - call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - do j=jscq,jecq - do i=iscq,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Zu(i,j) * Ru(i,j) - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Zv(i,j) * Rv(i,j) + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Du(i,j) * Au(i,j) - if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*Dv(i,j) * Av(i,j) - enddo - enddo - - dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & - jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) then + sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) + sum_vec_2(i,j) = resid_scale * Du(i,j) * Au(i,j) + endif + if (CS%vmask(i,j) == 1) then + sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) + sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Dv(i,j) * Av(i,j) + endif + enddo ; enddo - dot_p2 = reproducing_sum( sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & - jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) - endif + alpha_k = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & + reproducing_sum( sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) - alpha_k = dot_p1/dot_p2 - do j=jsd,jed - do i=isd,ied - if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) - if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(i,j) - enddo - enddo + do j=jsd,jed ; do i=isd,ied + if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) + if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(i,j) + enddo ; enddo - do j=jsd,jed - do i=isd,ied - if (CS%umask(i,j) == 1) then - Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) - endif - if (CS%vmask(i,j) == 1) then - Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) - endif - enddo - enddo + do j=jsd,jed ; do i=isd,ied + if (CS%umask(i,j) == 1) then + Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) + endif + if (CS%vmask(i,j) == 1) then + Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) + endif + enddo ; enddo ! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) ! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) @@ -1297,7 +1214,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo enddo - do j=jsdq,jedq do i=isdq,iedq if (CS%umask(i,j) == 1) then @@ -1311,50 +1227,22 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! R,u,v,Z valid region moves in by 1 - if (.not. CS%use_reproducing_sums) then - ! beta_k = (Z \dot R) / (Zold \dot Rold} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + resid_scale*Zu_old(i,j)*Ru_old(i,j) - endif - if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + resid_scale*Zv_old(i,j)*Rv_old(i,j) - endif - enddo - enddo - call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) - + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Zu(i,j) * Ru(i,j) - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Zv(i,j) * Rv(i,j) - - if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Zu_old(i,j) * Ru_old(i,j) - if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*Zv_old(i,j) * Rv_old(i,j) - enddo - enddo - - - dot_p1 = reproducing_sum(sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & - jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) - - dot_p2 = reproducing_sum(sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & - jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) - - endif - - beta_k = dot_p1/dot_p2 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) then + sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) + sum_vec_2(i,j) = resid_scale * Zu_old(i,j) * Ru_old(i,j) + endif + if (CS%vmask(i,j) == 1) then + sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) + sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Zv_old(i,j) * Rv_old(i,j) + endif + enddo ; enddo + beta_k = reproducing_sum(sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & + reproducing_sum(sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) ! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) ! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) @@ -1368,38 +1256,14 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! D valid region moves in by 1 - dot_p1 = 0 - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Ru(i,j)**2 - endif - if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Rv(i,j)**2 - endif - enddo - enddo - call sum_across_PEs(dot_p1) - - else - - sum_vec(:,:) = 0.0 - - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Rv(i,j)**2 - enddo - enddo - - dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & - jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) - endif + sum_vec(:,:) = 0.0 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*Rv(i,j)**2 + enddo ; enddo - dot_p1 = sqrt (dot_p1) + dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) + dot_p1 = sqrt(dot_p1) if (dot_p1 <= CS%cg_tolerance * resid0) then iters = iter @@ -1446,7 +1310,7 @@ end subroutine ice_shelf_solve_inner subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, intent(in) :: time_step !< The time step for this update [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -1481,7 +1345,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl integer :: i_off, j_off logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. - real :: u_face ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: u_face ! Zonal velocity at a face, positive if out {L Z-1 ~> m s-1] real :: flux_diff_cell real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character (len=1) :: debug_str @@ -1675,7 +1539,7 @@ end subroutine ice_shelf_advect_thickness_x subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, intent(in) :: time_step !< The time step for this update [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -1711,7 +1575,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, integer :: i_off, j_off logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. - real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] real :: flux_diff_cell real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character(len=1) :: debug_str @@ -2107,7 +1971,7 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask -subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) +subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -2116,14 +1980,14 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taud_x !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + intent(inout) :: taudx !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taud_y !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + intent(inout) :: taudy !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] ! This will become [R L3 Z T-2 ~> kg m s-2] ! driving stress! -! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. +! ! taudx and taudy will hold driving stress in the x- and y- directions when done. ! they will sit on the BGrid, and so their size depends on whether the grid is symmetric ! ! Since this is a finite element solve, they will actually have the form \int \Phi_i rho g h \nabla s @@ -2141,8 +2005,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] real :: dxh, dyh ! Local grid spacing [L ~> m] real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: taud_scale ! The conversion factor from scaled to MKS units for taud_x and - ! taud_y [kg s-2 R-1 L-2 Z-1 T2 ~> 1] integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec @@ -2160,7 +2022,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) rho = CS%density_ice rhow = CS%density_ocean_avg grav = CS%g_Earth - taud_scale = US%R_to_kg_m3*US%Z_to_m**US%L_T_to_m_s**2 ! prelim - go through and calculate S @@ -2247,20 +2108,20 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) endif ! SW vertex - taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! SE vertex - taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! NW vertex - taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! NE vertex - taud_x(I,J) = taud_x(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I,J) = taud_y(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) if (CS%ground_frac(i,j) == 1) then neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) @@ -2278,26 +2139,26 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) ! is not above the base of the ice in the current cell ! Note the negative sign due to the direction of the normal vector - taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * taud_scale * dyh * neumann_val - taud_x(i-1,j) = taud_x(i-1,j) - .5 * taud_scale * dyh * neumann_val + taudx(I-1,J-1) = taudx(I-1,J-1) - .5 * dyh * neumann_val + taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val endif if ((CS%u_face_mask(i,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then ! right face of the cell is at a stress boundary - taud_x(i,j-1) = taud_x(i,j-1) + .5 * taud_scale * dyh * neumann_val - taud_x(i,j) = taud_x(i,j) + .5 * taud_scale * dyh * neumann_val + taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val + taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif if ((CS%v_face_mask(i,j-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then ! south face of the cell is at a stress boundary - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * taud_scale * dxh * neumann_val - taud_y(i,j-1) = taud_y(i,j-1) - .5 * taud_scale * dxh * neumann_val + taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val + taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif if ((CS%v_face_mask(i,j) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then ! north face of the cell is at a stress boundary - taud_y(i-1,j) = taud_y(i-1,j) + .5 * taud_scale * dxh * neumann_val - taud_y(i,j) = taud_y(i,j) + .5 * taud_scale * dxh * neumann_val + taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val + taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val endif endif @@ -2314,7 +2175,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, intent(in) :: input_flux !< The integrated inward ice thickness flux per - !! unit face length [Z L s-1 ~> m2 s-1] + !! unit face length [Z L T-1 ~> m2 s-1] real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted @@ -2325,20 +2186,14 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! need to update those velocity points not *technically* in any ! computational domain -- if this function gets moves to another module, ! DO NOT TAKE THE RESTARTING BIT WITH IT - integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: i, j , isd, jsd, ied, jed integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec integer :: i_off, j_off - real :: A, n, ux, uy, vx, vy, eps_min, domain_width - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed -! iegq = G%iegq ; jegq = G%jegq i_off = G%idg_offset ; j_off = G%jdg_offset - domain_width = G%len_lat - ! this loop results in some values being set twice but... eh. do j=jsd,jed @@ -2379,13 +2234,13 @@ end subroutine init_boundary_values subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & - nu, float_cond, bathyT, beta, dxdyh, G, US, is, ie, js, je, dens_ratio) + ice_visc, float_cond, bathyT, basal_trac, dxdyh, G, US, is, ie, js, je, dens_ratio) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: uret !< The retarding stresses working at u-points. [L ? ~> m ?] + intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: vret !< The retarding stresses working at v-points. [L ? ~> m ?] + intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(SZDI_(G),SZDJ_(G),8,4), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. @@ -2393,9 +2248,9 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point @@ -2409,7 +2264,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: nu !< A field related to the ice viscosity from Glen's + intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the !! basal law exponent. [?] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2418,7 +2273,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: beta !< A field related to the nonlinear part of the + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and !! units depend on the basal law exponent. [L-2 ? ~> m-2 ?] ! and/or whether flow is "hybridized" @@ -2451,34 +2306,16 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas ! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q ! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear - real :: ux, vx, uy, vy, uq, vq, basel - real :: area + real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] + real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] integer :: iq, jq, iphi, jphi, i, j, ilq, jlq real, dimension(2) :: xquad real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr ! ,Ucontr xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - do j=js,je - do i=is,ie ; if (hmask(i,j) == 1) then -! dxh = G%dxh(i,j) -! dyh = G%dyh(i,j) -! -! X(:,:) = G%geoLonBu(i-1:i,j-1:j)*US%m_to_L -! Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*US%m_to_L -! -! call bilinear_shape_functions(X, Y, Phi, area) + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - - area = dxdyh(i,j) - - ! Ucontr=0 do iq=1,2 ; do jq=1,2 uq = u_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & @@ -2513,13 +2350,13 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas do iphi=1,2 ; do jphi=1,2 if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & - 0.25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + 0.25 * dxdyh(i,j) * ice_visc(i,j) * & + ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) endif if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & - 0.25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + 0.25 * dxdyh(i,j) * ice_visc(i,j) * & + ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) endif @@ -2528,13 +2365,13 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas jlq = 1 ; if (jq == jphi) jlq = 2 if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & - 0.25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * dxdyh(i,j) * uq * xquad(ilq) * xquad(jlq) endif if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & - 0.25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * dxdyh(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2542,22 +2379,21 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = bathyT(i,j) + Usubcontr = 0.0 ; Vsubcontr = 0.0 Ucell(:,:) = u_shlf(i-1:i,j-1:j) ; Vcell(:,:) = v_shlf(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, area, basel, & + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, dxdyh(i,j), bathyT(i,j), & dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi=1,2 if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) endif if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif - endif - enddo ; enddo + endif ; enddo ; enddo end subroutine CG_action @@ -2566,62 +2402,44 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, U intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. - real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] - real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction basal stress [L3 yr-1 ~> m3 yr-1]. + !! the u-direction basal stress [L3 T-1 ~> m3 s-1]. real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction basal stress [L3 yr-1 ~> m3 yr-1]. + !! the v-direction basal stress [L3 T-1 ~> m3 s-1]. real :: subarea ! A sub-cell area [L2 ~> m2] real :: hloc ! The local sub-cell ice thickness [Z ~> m] - real :: uq, vq ! Local velocities [L yr-1 ~> m yr-1] - integer :: nsub, i, j, k, l, qx, qy, m, n + integer :: nsub, i, j, qx, qy, m, n nsub = size(Phisub,1) subarea = DXDYH / (nsub**2) - do m=1,2 - do n=1,2 - do j=1,nsub - do i=1,nsub - do qx=1,2 - do qy = 1,2 - - hloc = Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,1,2,qx,qy)*H(1,2) + & - Phisub(i,j,2,1,qx,qy)*H(2,1) + Phisub(i,j,2,2,qx,qy)*H(2,2) - - if (dens_ratio * hloc - bathyT > 0) then - !if (.true.) then - uq = 0 ; vq = 0 - do k=1,2 - do l=1,2 - ! Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) - ! Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) - uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) - enddo - enddo - - Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq - Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq - - endif - - enddo - enddo - enddo - enddo - enddo - enddo + do n=1,2 ; do m=1,2 + Ucontr(m,n) = 0.0 ; Vcontr(m,n) = 0.0 + do qy=1,2 ; do qx=1,2 ; do j=1,nsub ; do i=1,nsub + hloc = (Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,2,2,qx,qy)*H(2,2)) + & + (Phisub(i,j,1,2,qx,qy)*H(1,2) + Phisub(i,j,2,1,qx,qy)*H(2,1)) + if (dens_ratio * hloc - bathyT > 0) then ! if (.true.) then + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & + ((Phisub(i,j,1,1,qx,qy) * U(1,1) + Phisub(i,j,2,2,qx,qy) * U(2,2)) + & + (Phisub(i,j,1,2,qx,qy) * U(1,2) + Phisub(i,j,2,1,qx,qy) * U(2,1))) + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & + ((Phisub(i,j,1,1,qx,qy) * V(1,1) + Phisub(i,j,2,2,qx,qy) * V(2,2)) + & + (Phisub(i,j,1,2,qx,qy) * V(1,2) + Phisub(i,j,2,1,qx,qy) * V(2,1))) + endif + enddo ; enddo ; enddo ; enddo + enddo ; enddo end subroutine CG_action_subgrid_basal !> returns the diagonal entries of the matrix for a Jacobi preconditioning -subroutine matrix_diagonal(CS, G, US, float_cond, H_node, nu, beta, hmask, dens_ratio, & +subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, hmask, dens_ratio, & Phisub, u_diagonal, v_diagonal) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure @@ -2634,11 +2452,11 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, nu, beta, hmask, dens_ intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: nu !< A field related to the ice viscosity from Glen's + intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the !! basal law exponent. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: beta !< A field related to the nonlinear part of the + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and !! units depend on the basal law exponent [L-2 ? ~> m-2 ?] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2650,115 +2468,83 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, nu, beta, hmask, dens_ !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity - !! matrix from the left-hand side of the solver [same units as nu]. + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity - !! matrix from the left-hand side of the solver [same units as nu]. + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] ! returns the diagonal entries of the matrix for a Jacobi preconditioning integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width - real :: area, uq, vq, basel - real, dimension(8,4) :: Phi ! [L-1 ~> m-1] - real, dimension(4) :: X, Y ! Sub-cell positions [L ~> m] - real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr - + real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] + real :: uq, vq + real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] + real, dimension(2) :: xquad + real, dimension(2,2) :: Hcell, Usubcontr, Vsubcontr isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L - X(3:4) = G%geoLonBu(i-1:i,j) *1000.0*US%m_to_L - Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000.0*US%m_to_L - Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L - - call bilinear_shape_functions(X, Y, Phi, area) + call bilinear_shape_fn_grid(G, i, j, Phi) - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do iq=1,2 ; do jq=1,2 + do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 - do iphi=1,2 ; do jphi=1,2 + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif + ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = 0. + vy = 0. - if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - - ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - vx = 0. - vy = 0. - - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * G%areaT(i,j) * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) == 0) then - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & - 0.25 * beta(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) - endif - + !### uq seems to be duplicated here. Why not uq**2? + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif + endif - if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then - vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - ux = 0. - uy = 0. + vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = 0. + uy = 0. - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * G%areaT(i,j) * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + if (float_cond(i,j) == 0) then vq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) == 0) then - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & - 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) - endif - + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif - enddo ; enddo - enddo ; enddo + endif + enddo ; enddo ; enddo ; enddo + if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Usubcontr = 0.0 ; Vsubcontr = 0.0 Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), basel, dens_ratio, Usubcontr, Vsubcontr) + call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), G%bathyT(i,j), dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi=1,2 if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2805,7 +2591,7 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, end subroutine CG_diagonal_subgrid_basal -subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, float_cond, & +subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, basal_trac, float_cond, & dens_ratio, u_bdry_contr, v_bdry_contr) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure @@ -2821,11 +2607,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: nu !< A field related to the ice viscosity from Glen's + intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the !! basal law exponent. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: beta !< A field related to the nonlinear part of the + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and !! units depend on the basal law exponent [L-2 ~> m-2] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2834,34 +2620,27 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u_bdry_contr !< Contributions to the zonal ice - !! velocities due to the open boundaries [L yr-1 ~> m yr-1] + intent(inout) :: u_bdry_contr !< Zonal force contributions due to the + !! open boundaries [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_bdry_contr !< Contributions to the zonal ice - !! velocities due to the open boundaries [L yr-1 ~> m yr-1] + intent(inout) :: v_bdry_contr !< Meridional force contributions due to the + !! open boundaries [R L3 Z T-2 ~> kg m s-2] ! this will be a per-setup function. the boundary values of thickness and velocity ! (and possibly other variables) will be updated in this function real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y real, dimension(2) :: xquad integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, uq, vq, area, basel + real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] + real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] + real :: area real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then ! process this cell if any corners have umask set to non-dirichlet bdry. @@ -2870,17 +2649,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, if ((CS%umask(i-1,j-1) == 3) .OR. (CS%umask(i,j-1) == 3) .OR. & (CS%umask(i-1,j) == 3) .OR. (CS%umask(i,j) == 3)) then - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L - X(3:4) = G%geoLonBu(i-1:i,j)*1000.0*US%m_to_L - Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000.0*US%m_to_L - Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L - - call bilinear_shape_functions(X, Y, Phi, area) + call bilinear_shape_fn_grid(G, i, j, Phi) - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j @@ -2917,43 +2687,29 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, CS%v_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) do iphi=1,2 ; do jphi=1,2 - - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 if (CS%umask(i-2+iphi,j-2+jphi) == 1) then u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * G%areaT(i,j) * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & - 0.25 * beta(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif - endif if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then - - v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + 0.25 * G%areaT(i,j) * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & - 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif - endif enddo ; enddo enddo ; enddo @@ -2967,11 +2723,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, do iphi=1,2 ; do jphi = 1,2 if (CS%umask(i-2+iphi,j-2+jphi) == 1) then u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & - Usubcontr(iphi,jphi) * beta(i,j) + Usubcontr(iphi,jphi) * basal_trac(i,j) endif if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & - Vsubcontr(iphi,jphi) * beta(i,j) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2989,9 +2745,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity [L yr-1 ~> m yr-1]. + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity [L yr-1 ~> m yr-1]. + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve ! so there is an "upper" and "lower" bilinear viscosity @@ -3002,10 +2758,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n - real :: ux, uy, vx, vy, eps_min ! Velocity shears [yr-1] - real :: umid, vmid, unorm ! Velocities [L yr-1 ~> m yr-1] - real :: n_basal_friction + real :: Visc_coef, n_g + real :: ux, uy, vx, vy, eps_min ! Velocity shears [T-1 ~> s-1] + real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -3015,26 +2770,25 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 - A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - n_basal_friction = CS%n_basal_friction + n_g = CS%n_glen; eps_min = CS%eps_glen_min + + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(1./CS%n_glen) do j=jsd+1,jed-1 do i=isd+1,ied-1 if (ISS%hmask(i,j) == 1) then - ux = (u_shlf(i,j) + u_shlf(i,j-1) - u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dxT(i,j)) - vx = (v_shlf(i,j) + v_shlf(i,j-1) - v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dxT(i,j)) - uy = (u_shlf(i,j) - u_shlf(i,j-1) + u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dyT(i,j)) - vy = (v_shlf(i,j) - v_shlf(i,j-1) + v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dyT(i,j)) - - CS%ice_visc(i,j) = .5 * A**(-1/n) * & - (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2) ** ((1-n)/(2*n)) * & - US%Z_to_m*ISS%h_shelf(i,j) - - umid = (u_shlf(i,j) + u_shlf(i,j-1) + u_shlf(i-1,j) + u_shlf(i-1,j-1))/4 - vmid = (v_shlf(i,j) + v_shlf(i,j-1) + v_shlf(i-1,j) + v_shlf(i-1,j-1))/4 - unorm = sqrt (umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) - CS%taub_beta_eff(i,j) = US%L_to_m**2*CS%C_basal_friction * (US%L_to_m*unorm)**(n_basal_friction-1) + ux = ((u_shlf(I,J) + u_shlf(I,J-1)) - (u_shlf(I-1,J) + u_shlf(I-1,J-1))) / (2*G%dxT(i,j)) + vx = ((v_shlf(I,J) + v_shlf(I,J-1)) - (v_shlf(I-1,J) + v_shlf(I-1,J-1))) / (2*G%dxT(i,j)) + uy = ((u_shlf(I,J) + u_shlf(I-1,J)) - (u_shlf(I,J-1) + u_shlf(I-1,J-1))) / (2*G%dyT(i,j)) + vy = ((v_shlf(I,J) + v_shlf(I-1,J)) - (v_shlf(I,J-1) + v_shlf(I-1,J-1))) / (2*G%dyT(i,j)) + CS%ice_visc(i,j) = 0.5 * Visc_coef * ISS%h_shelf(i,j) * & + (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + + umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 + vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 + unorm = sqrt(umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) + CS%basal_traction(i,j) = CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo enddo @@ -3110,7 +2864,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) end subroutine update_OD_ffrac_uncoupled !> This subroutine calculates the gradients of bilinear basis elements that -!! that are centered at the vertices of the cell. values are calculated at +!! that are centered at the vertices of the cell. Values are calculated at !! points of gaussian quadrature. subroutine bilinear_shape_functions (X, Y, Phi, area) real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. @@ -3151,11 +2905,6 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) - ! a = (X(2)-X(1)) * (1-yquad(qpoint)) + (X(4)-X(3)) * yquad(qpoint) ! d(x)/d(x*) - ! b = (Y(2)-Y(1)) * (1-yquad(qpoint)) + (Y(4)-Y(3)) * yquad(qpoint) ! d(y)/d(x*) - ! c = (X(3)-X(1)) * (1-xquad(qpoint)) + (X(4)-X(2)) * xquad(qpoint) ! d(x)/d(y*) - ! d = (Y(3)-Y(1)) * (1-xquad(qpoint)) + (Y(4)-Y(2)) * xquad(qpoint) ! d(y)/d(y*) - do node=1,4 xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) @@ -3182,6 +2931,62 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) end subroutine bilinear_shape_functions +!> This subroutine calculates the gradients of bilinear basis elements that are centered at the +!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at +!! points of gaussian quadrature. +subroutine bilinear_shape_fn_grid(G, i, j, Phi) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + integer, intent(in) :: i !< The i-index in the grid to work on. + integer, intent(in) :: j !< The j-index in the grid to work on. + real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + +! This subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. The values are calculated at +! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) +! (ordered in same way as vertices) +! +! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear +! +! This should be a one-off; once per nonlinear solve? once per lifetime? + + real, dimension(4) :: xquad, yquad ! [nondim] + real :: a, d ! Interpolated grid spacings [L ~> m] + real :: xexp, yexp ! [nondim] + integer :: node, qpoint, xnode, xq, ynode, yq + + xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) + xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) + + do qpoint=1,4 + a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) + d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) + + do node=1,4 + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + + if (ynode == 1) then + yexp = 1-yquad(qpoint) + else + yexp = yquad(qpoint) + endif + + if (1 == xnode) then + xexp = 1-xquad(qpoint) + else + xexp = xquad(qpoint) + endif + + Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp ) / (a*d) + Phi(2*node,qpoint) = ( a * (2 * ynode - 3) * xexp ) / (a*d) + + enddo + enddo + +end subroutine bilinear_shape_fn_grid + subroutine bilinear_shape_functions_subgrid(Phisub, nsub) real, dimension(nsub,nsub,2,2,2,2), & @@ -3219,33 +3024,17 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) fracx = 1.0/real(nsub) - do j=1,nsub - do i=1,nsub - x0 = (i-1) * fracx ; y0 = (j-1) * fracx - do qx=1,2 - do qy=1,2 - x = x0 + fracx*xquad(qx) - y = y0 + fracx*xquad(qy) - do k=1,2 - do l=1,2 - val = 1.0 - if (k == 1) then - val = val * (1.0-x) - else - val = val * x - endif - if (l == 1) then - val = val * (1.0-y) - else - val = val * y - endif - Phisub(i,j,k,l,qx,qy) = val - enddo - enddo - enddo - enddo - enddo - enddo + do j=1,nsub ; do i=1,nsub + x0 = (i-1) * fracx ; y0 = (j-1) * fracx + do qy=1,2 ; do qx=1,2 + x = x0 + fracx*xquad(qx) + y = y0 + fracx*xquad(qy) + Phisub(i,j,1,1,qx,qy) = (1.0-x) * (1.0-y) + Phisub(i,j,1,2,qx,qy) = (1.0-x) * y + Phisub(i,j,2,1,qx,qy) = x * (1.0-y) + Phisub(i,j,2,2,qx,qy) = x * y + enddo ; enddo + enddo ; enddo end subroutine bilinear_shape_functions_subgrid @@ -3462,7 +3251,7 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%u_face_mask, CS%v_face_mask) deallocate(CS%umask, CS%vmask) - deallocate(CS%ice_visc, CS%taub_beta_eff) + deallocate(CS%ice_visc, CS%basal_traction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%ground_frac, CS%ground_frac_rt) @@ -3474,14 +3263,14 @@ end subroutine ice_shelf_dyn_end !> This subroutine updates the vertically averaged ice shelf temperature. subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state - type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, intent(in) :: time_step !< The time step for this update [s]. + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] - type(time_type), intent(in) :: Time !< The current model time + intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] + type(time_type), intent(in) :: Time !< The current model time ! 5/23/12 OVS ! This subroutine takes the velocity (on the Bgrid) and timesteps @@ -3517,13 +3306,11 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec real :: t_bd, Tsurf - real :: spy ! The amount of time in a year [T ~> s] real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. - spy = 365. * 86400. * US%s_to_T ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later - adot = 0.1*US%m_to_Z / spy + adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s Tsurf = -20.0 isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3533,32 +3320,27 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) th_after_uflux(:,:) = 0.0 th_after_vflux(:,:) = 0.0 - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_bdry_val(i,j) -! if (ISS%hmask(i,j) > 1) then - if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then - CS%t_shelf(i,j) = CS%t_bdry_val(i,j) - endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) - enddo - enddo + do j=jsd,jed ; do i=isd,ied + t_bd = CS%t_bdry_val(i,j) +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) + endif + enddo ; enddo + do j=jsd,jed ; do i=isd,ied + TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) + enddo ; enddo -! call enable_averaging(time_step,Time,CS%diag) +! call enable_averages(time_step, Time, CS%diag) ! call pass_var(h_after_uflux, G%domain) ! call pass_var(h_after_vflux, G%domain) ! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) ! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) - call ice_shelf_advect_temp_x(CS, G, US%s_to_T*time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, G, US%s_to_T*time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + call ice_shelf_advect_temp_x(CS, G, time_step, ISS%hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) do j=jsd,jed do i=isd,ied @@ -3586,10 +3368,11 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) do i=isc,iec if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then if (ISS%h_shelf(i,j) > 0.0) then + !### Why is the hard-coded code uncommented and the plausible one commented out? ! CS%t_shelf(i,j) = CS%t_shelf(i,j) + & -! US%s_to_T*time_step*(adot*Tsurf - US%R_to_kg_m3*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) - CS%t_shelf(i,j) = CS%t_shelf(i,j) + & - US%s_to_T*time_step*(adot*Tsurf - (3.0*US%m_to_Z/spy)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) +! time_step*(adot*Tsurf - US%R_to_kg_m3*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step * & + (adot*Tsurf - ((3.0/(365.0*86400.0))*US%m_to_Z*US%T_to_s)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) else ! the ice is about to melt away ! in this case set thickness, area, and mask to zero @@ -3616,7 +3399,7 @@ end subroutine ice_shelf_temp subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - real, intent(in) :: time_step !< The time step for this update [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -3651,7 +3434,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f integer :: i_off, j_off logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil - real :: u_face ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: u_face ! Zonal velocity at a face, positive if out {L T-1 ~> m s-1] real :: flux_diff_cell, phi character (len=1) :: debug_str @@ -3845,7 +3628,7 @@ end subroutine ice_shelf_advect_temp_x subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, intent(in) :: time_step !< The time step for this update [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -3881,7 +3664,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft integer :: i_off, j_off logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil - real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] real :: flux_diff_cell, phi character(len=1) :: debug_str diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index f34b3c70f4..20479531a8 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -247,20 +247,20 @@ end subroutine initialize_ice_thickness_channel ! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through -! !! C-grid u faces [L Z s-1 ~> m2 s-1]. +! !! C-grid u faces [L Z T-1 ~> m2 s-1]. ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through -! !! C-grid v faces [L Z s-1 ~> m2 s-1]. +! !! C-grid v faces [L Z T-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open -! !! boundary vertices [m yr-1]. +! !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open -! !! boundary vertices [m yr-1]. +! !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] ! real, dimension(SZDI_(G),SZDJ_(G)), & ! intent(inout) :: hmask !< A mask indicating which tracer points are ! !! partly or fully covered by an ice-shelf @@ -304,20 +304,20 @@ end subroutine initialize_ice_thickness_channel ! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through -! !! C-grid u faces [L Z s-1 ~> m2 s-1]. +! !! C-grid u faces [L Z T-1 ~> m2 s-1]. ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces ! real, dimension(SZI_(G),SZJB_(G)), & ! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through -! !! C-grid v faces [L Z s-1 ~> m2 s-1]. +! !! C-grid v faces [L Z T-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [m yr-1]. + !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - !! boundary vertices [m yr-1]. + !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] ! real, dimension(SZDI_(G),SZDJ_(G)), & ! intent(inout) :: hmask !< A mask indicating which tracer points are ! !! partly or fully covered by an ice-shelf @@ -327,18 +327,18 @@ end subroutine initialize_ice_thickness_channel ! character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. ! integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, ied, jed -! real :: input_thick -! real :: input_flux ! The input ice flux per unit length [L Z t-1 ~> m2 s-1] +! real :: input_thick ! The input ice shelf thickness [Z ~> m] +! real :: input_flux ! The input ice flux per unit length [L Z T-1 ~> m2 s-1] ! real :: lenlat, len_stress ! call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) ! call get_param(PF, mdl, "INPUT_FLUX_ICE_SHELF", input_flux, & ! "volume flux at upstream boundary", & -! units="m2 s-1", default=0., scale=US%m_to_L*US%m_to_Z) +! units="m2 s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) ! call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & ! "flux thickness at upstream boundary", & -! units="m", default=1000.) +! units="m", default=1000., scale=US%m_to_Z) ! call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & ! "maximum position of no-flow condition in along-flow direction", & ! units="km", default=0.) From 185b42e945d4241568f6a5354e9d80c6129f5a8b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Mar 2020 05:51:52 -0400 Subject: [PATCH 117/137] +Renamed solo_time_step to solo_step_ice_shelf Renamed to routine to step the ice shelf without an ocean model to solo_step_ice_shelf for greater clarity, and change the time interval argument into a time_type variable. Also added dimensional rescaling of the internal real time variables in solo_step_ice_shelf. All answers are bitwise identical in the MOM6-examples test cases, but it should be noted that there are no active tests of the ice shelf dynamics code. --- .../ice_solo_driver/ice_shelf_driver.F90 | 4 +- src/ice_shelf/MOM_ice_shelf.F90 | 66 +++++++++---------- 2 files changed, 32 insertions(+), 38 deletions(-) diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 828dbf301c..f2c5099544 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -50,7 +50,7 @@ program SHELF_main use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - use MOM_ice_shelf, only : ice_shelf_save_restart, solo_time_step + use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf ! , add_shelf_flux_forcing, add_shelf_flux_IOB implicit none @@ -330,7 +330,7 @@ program SHELF_main ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_time_step (ice_shelf_CSp, time_step, m, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, m, Time) ! Time = Time + Time_step_ocean ! This is here to enable fractional-second time steps. diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index cd3ba3fd44..d05631c621 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -8,8 +8,8 @@ module MOM_ice_shelf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid -use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid, diag_ctrl, time_type +use MOM_diag_mediator, only : enable_averages, enable_averaging, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -26,7 +26,7 @@ module MOM_ice_shelf use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_time_manager, only : time_type, time_type_to_real, time_type_to_real, real_to_time +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling use MOM_variables, only : surface @@ -60,7 +60,7 @@ module MOM_ice_shelf #endif public shelf_calc_flux, add_shelf_flux, initialize_ice_shelf, ice_shelf_end -public ice_shelf_save_restart, solo_time_step, add_shelf_forces +public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -1786,72 +1786,66 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_time_step(CS, time_interval, nsteps, Time, min_time_step_in) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_interval !< The time interval for this update [s]. +subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(time_type), intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. - type(time_type), intent(inout) :: Time !< The current model time - real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [s]. + type(time_type), intent(inout) :: Time !< The current model time + real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [T ~> s]. - type(ocean_grid_type), pointer :: G => NULL() + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state - integer :: is, iec, js, jec, i, j - real :: time_step - real :: time_step_remain - real :: time_step_int, min_time_step + real :: remaining_time ! The remaining time in this call [T ~> s] + real :: time_step ! The internal time step during this call [T ~> s] + real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true the grouding line position is determined based on ! coupled ice-ocean dynamics. + integer :: is, iec, js, jec, i, j G => CS%grid US => CS%US ISS => CS%ISS is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - time_step = time_interval + remaining_time = US%s_to_T*time_type_to_real(time_interval) - time_step_remain = time_step if (present (min_time_step_in)) then min_time_step = min_time_step_in else - min_time_step = 1000.0 ! This is in seconds - at 1 km resolution it would imply ice is moving at ~1 meter per second + min_time_step = 1000.0*US%s_to_T ! At 1 km resolution this would imply ice is moving at ~1 meter per second endif write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) - call MOM_mesg("solo_time_step: "//mesg) + call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) - do while (time_step_remain > 0.0) + do while (remaining_time > 0.0) nsteps = nsteps+1 - ! If time_step is not too long, this is unnecessary. - time_step_int = min(US%T_to_s*ice_time_step_CFL(CS%dCS, ISS, G), time_step) + ! If time_interval is not too long, this is unnecessary. + time_step = min(ice_time_step_CFL(CS%dCS, ISS, G), remaining_time) - write (mesg,*) "Ice model timestep = ", time_step_int, " seconds" - if (time_step_int < min_time_step) then - call MOM_error(FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep "//mesg) + write (mesg,*) "Ice model timestep = ", US%T_to_s*time_step, " seconds" + if ((time_step < min_time_step) .and. (time_step < remaining_time)) then + call MOM_error(FATAL, "MOM_ice_shelf:solo_step_ice_shelf: abnormally small timestep "//mesg) else - call MOM_mesg("solo_time_step: "//mesg) + call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif - if (time_step_int >= time_step_remain) then - time_step_int = time_step_remain - time_step_remain = 0.0 - else - time_step_remain = time_step_remain - time_step_int - endif + remaining_time = remaining_time - time_step ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. ! Do not update the velocities if the last step is very short. - update_ice_vel = ((time_step_int > min_time_step) .or. (time_step_int >= time_step)) + update_ice_vel = ((time_step > min_time_step) .or. (remaining_time > 0.0)) coupled_GL = .false. - call update_ice_shelf(CS%dCS, ISS, G, US, US%s_to_T*time_step_int, Time, must_update_vel=update_ice_vel) + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) - call enable_averaging(time_step,Time,CS%diag) + call enable_averages(time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) @@ -1859,7 +1853,7 @@ subroutine solo_time_step(CS, time_interval, nsteps, Time, min_time_step_in) enddo -end subroutine solo_time_step +end subroutine solo_step_ice_shelf !> \namespace mom_ice_shelf !! @@ -1877,7 +1871,7 @@ end subroutine solo_time_step !! h_shelf and density_ice immediately afterwards. Possibly subroutine should be renamed !! update_shelf_mass - updates ice shelf mass via netCDF file !! USER_update_shelf_mass (TODO). -!! solo_time_step - called only in ice-only mode. +!! solo_step_ice_shelf - called only in ice-only mode. !! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is !! updated immediately after ice_shelf_advect in fully dynamic mode. !! From e45326b263ffed2400bfcab648b2ec2fba3b5786 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Mar 2020 09:03:23 -0400 Subject: [PATCH 118/137] (*)+Fix grid length use in MOM_ice_shelf_dynamics.F90 Corrected the grid face lengths used to calculate the mass and tracer fluxes. This will change answers on a non-Cartesian grid, and because of some bug corrections, it will change answers if the x- and y- grid spacings are not the same. Added comments with the correct units for several variables. Rearranged the order of indices in Phi for more efficient memory access. Applied the MOM6 convention to the case of indicies to indicate grid staggering. Some variable names were changed for brevity. All answers are bitwise identical in the MOM6-examples test cases, but there are substantial changes to the MOM_ice_shelf_dynamics.F90 code and it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 730 +++++++++++------------ 1 file changed, 361 insertions(+), 369 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 908e79896a..0aae1d35f8 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -72,7 +72,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_shelf => NULL() !< Veritcally integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. - real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, perhaps in [m]. + real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] @@ -81,8 +81,8 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< nonlinear part of "linearized" basal stress. - !! [L-2 ? ~> m-2 ?] + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The nonlinear part of "linearized" + !! basal stress [R Z T-1 ~> kg m-2 s-1]. !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. @@ -255,9 +255,9 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & - "Glens law ice viscosity", "m (seems wrong)") + "Volume integrated Glens law ice viscosity", "kg m2 s-1") call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & - "Coefficient of basal traction", "m (seems wrong)") + "Coefficient of basal traction", "kg m-2 s-1") endif end subroutine register_ice_shelf_dyn_restarts @@ -460,15 +460,18 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! This has to occur after init_boundary_values or some of the arrays on the ! right hand side have not been set up yet. if (.not. G%symmetric) then - !### What about v_shelf? do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then - CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) - CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) endif - if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then - CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) - CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif enddo ; enddo endif @@ -811,8 +814,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) ! quadrature points surrounding the cell verticies [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] - real, dimension(8,4) :: Phi_temp ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding a cell vertex [L-1 ~> m-1]. character(2) :: iternum character(2) :: numproc @@ -867,11 +868,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) endif ! must prepare Phi - allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:) = 0.0 + allocate(Phi(1:8,1:4,isd:ied,jsd:jed)) ; Phi(:,:,:,:) = 0.0 do j=jsd,jed ; do i=isd,ied - call bilinear_shape_fn_grid(G, i, j, Phi_temp) - Phi(i,j,:,:) = Phi_temp + call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) @@ -891,7 +891,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) Au(:,:) = 0.0 ; Av(:,:) = 0.0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) if (CS%nonlin_solve_err_mode == 1) then @@ -901,7 +901,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu endif - if (CS%vmask(i,j) == 1) then + if (CS%vmask(I,J) == 1) then err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) if (err_tempv >= err_init) err_init = err_tempv endif @@ -946,7 +946,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) Au(:,:) = 0 ; Av(:,:) = 0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) err_max = 0 @@ -970,7 +970,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) max_vel = 0 ; tempu = 0 ; tempv = 0 do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB - if (CS%umask(i,j) == 1) then + if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) if (err_tempu >= err_max) err_max = err_tempu tempu = u_shlf(I,J) @@ -1037,7 +1037,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! iterations have converged to the specified tolerence integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDI_(G),SZDJ_(G),8,4), & + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & @@ -1114,7 +1114,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & - G%areaT, G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) @@ -1126,8 +1126,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*Rv(i,j)**2 + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo dot_p1 = reproducing_sum( sum_vec, Js_sum, Ie_sum, Js_sum, Je_sum ) @@ -1136,8 +1136,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsdq,jedq do i=isdq,iedq - if (CS%umask(i,j) == 1) Zu(i,j) = Ru(i,j) / DIAGu(i,j) - if (CS%vmask(i,j) == 1) Zv(i,j) = Rv(i,j) / DIAGv(i,j) + if (CS%umask(I,J) == 1) Zu(I,J) = Ru(I,J) / DIAGu(I,J) + if (CS%vmask(I,J) == 1) Zv(I,J) = Rv(I,J) / DIAGv(I,J) enddo enddo @@ -1168,7 +1168,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & - G%areaT, G, US, is, ie, js, je, rhoi_rhow) + G, US, is, ie, js, je, rhoi_rhow) ! Au, Av valid region moves in by 1 @@ -1176,13 +1176,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) then - sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) - sum_vec_2(i,j) = resid_scale * Du(i,j) * Au(i,j) + if (CS%umask(I,J) == 1) then + sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) + sum_vec_2(I,J) = resid_scale * Du(I,J) * Au(I,J) endif - if (CS%vmask(i,j) == 1) then - sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) - sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Dv(i,j) * Av(i,j) + if (CS%vmask(I,J) == 1) then + sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Dv(I,J) * Av(I,J) endif enddo ; enddo @@ -1191,16 +1191,16 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsd,jed ; do i=isd,ied - if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) - if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(i,j) + if (CS%umask(I,J) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) + if (CS%vmask(I,J) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) enddo ; enddo do j=jsd,jed ; do i=isd,ied - if (CS%umask(i,j) == 1) then - Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) + if (CS%umask(I,J) == 1) then + Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J) endif - if (CS%vmask(i,j) == 1) then - Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) + if (CS%vmask(I,J) == 1) then + Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) endif enddo ; enddo @@ -1209,18 +1209,18 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsd,jed do i=isd,ied - if (CS%umask(i,j) == 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) - if (CS%vmask(i,j) == 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) + if (CS%umask(I,J) == 1) Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) + if (CS%vmask(I,J) == 1) Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) enddo enddo do j=jsdq,jedq do i=isdq,iedq - if (CS%umask(i,j) == 1) then - Zu(i,j) = Ru(i,j) / DIAGu(i,j) + if (CS%umask(I,J) == 1) then + Zu(I,J) = Ru(I,J) / DIAGu(I,J) endif - if (CS%vmask(i,j) == 1) then - Zv(i,j) = Rv(i,j) / DIAGv(i,j) + if (CS%vmask(I,J) == 1) then + Zv(I,J) = Rv(I,J) / DIAGv(I,J) endif enddo enddo @@ -1231,13 +1231,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) then - sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) - sum_vec_2(i,j) = resid_scale * Zu_old(i,j) * Ru_old(i,j) + if (CS%umask(I,J) == 1) then + sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) + sum_vec_2(I,J) = resid_scale * Zu_old(I,J) * Ru_old(I,J) endif - if (CS%vmask(i,j) == 1) then - sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) - sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Zv_old(i,j) * Rv_old(i,j) + if (CS%vmask(I,J) == 1) then + sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Zv_old(I,J) * Rv_old(I,J) endif enddo ; enddo @@ -1249,8 +1249,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsd,jed do i=isd,ied - if (CS%umask(i,j) == 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) - if (CS%vmask(i,j) == 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) + if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J) + if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) enddo enddo @@ -1258,8 +1258,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*Rv(i,j)**2 + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) @@ -1285,15 +1285,15 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsdq,jedq do i=isdq,iedq - if (CS%umask(i,j) == 3) then - u_shlf(I,J) = CS%u_bdry_val(i,j) - elseif (CS%umask(i,j) == 0) then + if (CS%umask(I,J) == 3) then + u_shlf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then u_shlf(I,J) = 0 endif - if (CS%vmask(i,j) == 3) then - v_shlf(I,J) = CS%v_bdry_val(i,j) - elseif (CS%vmask(i,j) == 0) then + if (CS%vmask(I,J) == 3) then + v_shlf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then v_shlf(I,J) = 0 endif enddo @@ -1346,7 +1346,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. real :: u_face ! Zonal velocity at a face, positive if out {L Z-1 ~> m s-1] - real :: flux_diff_cell + real :: flux_diff real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character (len=1) :: debug_str @@ -1383,18 +1383,18 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - flux_diff_cell = 0 + flux_diff = 0 ! 1ST DO LEFT FACE - if (CS%u_face_mask(i-1,j) == 4.) then + if (CS%u_face_mask(I-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) / G%areaT(i,j) + flux_diff = flux_diff + G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) / G%areaT(i,j) else ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available @@ -1403,32 +1403,29 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it stencil (-1) = CS%thickness_bdry_val(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j)* time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & (stencil(-1) - slope_lim * (stencil(-1)-stencil(0))/2) - else ! h(i-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i-2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(-1) + else ! h(i-1) is valid (o.w. flux would most likely be out of cell) but h(i-2) is not + flux_diff = flux_diff + ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * stencil(-1) endif elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * stencil(0) if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) endif endif endif @@ -1438,32 +1435,32 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! get u-velocity at center of right face - if (CS%u_face_mask(i+1,j) == 4.) then + if (CS%u_face_mask(I+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) / G%areaT(i,j) + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) / G%areaT(i,j) else - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (stencil(1) - slope_lim * (stencil(1)-stencil(0))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell + ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(1) + flux_diff = flux_diff + ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * stencil(1) endif @@ -1472,41 +1469,41 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (stencil(0)-stencil(1))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell - ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * stencil(0) if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) endif endif endif - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff endif elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i-1,j) - elseif (CS%u_face_mask(i-1,j) == 4.) then - flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) + u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) + flux_enter(i,j,1) = ABS(u_face) * G%dyCu(I-1,j) * time_step * CS%thickness_bdry_val(i-1,j) + elseif (CS%u_face_mask(I-1,j) == 4.) then + flux_enter(i,j,1) = G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) endif if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(i+1,j) == 4.) then - flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + flux_enter(i,j,2) = ABS(u_face) * G%dyCu(I,j) * time_step * CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(I+1,j) == 4.) then + flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) endif if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -1576,7 +1573,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] - real :: flux_diff_cell + real :: flux_diff real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character(len=1) :: debug_str @@ -1610,18 +1607,18 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux(i,j) = h_after_uflux(i,j) stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 + flux_diff = 0 ! 1ST DO south FACE - if (CS%v_face_mask(i,j-1) == 4.) then + if (CS%v_face_mask(i,J-1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) / G%areaT(i,j) + flux_diff = flux_diff + G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) / G%areaT(i,j) else ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + v_face = 0.5 * (CS%v_shelf(I-1,J-1) + CS%v_shelf(I,J-1)) if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available @@ -1629,32 +1626,31 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (stencil(-1) - slope_lim * (stencil(-1)-stencil(0))/2) else ! h(j-1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * stencil(-1) + flux_diff = flux_diff + ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * stencil(-1) endif elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * stencil(0) - !### The G%dyT in the next line needs to become G%dxCu(i,J-1) if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) endif endif @@ -1665,42 +1661,42 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! NEXT DO north FACE - if (CS%v_face_mask(i,j+1) == 4.) then + if (CS%v_face_mask(i,J+1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) / G%areaT(i,j) + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) / G%areaT(i,j) else - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + ! get v-velocity at center of north face + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (stencil(1) - slope_lim * (stencil(1)-stencil(0))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(1) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(1) endif elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (stencil(0)-stencil(1))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) endif endif @@ -1708,22 +1704,22 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, endif - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) - flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j-1) - elseif (CS%v_face_mask(i,j-1) == 4.) then - flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) + v_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I,J-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxCv(i,J-1) * time_step * CS%thickness_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,J-1) == 4.) then + flux_enter(i,j,3) = G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) endif if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) - flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j+1) - elseif (CS%v_face_mask(i,j+1) == 4.) then - flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) + v_face = 0.5 * (CS%u_shelf(I-1,J) + CS%u_shelf(I,J)) + flux_enter(i,j,4) = ABS(v_face) * G%dxCv(i,J) * time_step * CS%thickness_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,J+1) == 4.) then + flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) endif if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then @@ -1875,13 +1871,13 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) n_flux = 0 ; new_partial(:) = 0 do k=1,2 - if (CS%u_face_mask(i-2+k,j) == 2) then + if (CS%u_face_mask(I-2+k,j) == 2) then n_flux = n_flux + 1 elseif (ISS%hmask(i+2*k-3,j) == 0) then n_flux = n_flux + 1 new_partial(k) = 1 endif - if (CS%v_face_mask(i,j-2+k) == 2) then + if (CS%v_face_mask(i,J-2+k) == 2) then n_flux = n_flux + 1 elseif (ISS%hmask(i,j+2*k-3) == 0) then n_flux = n_flux + 1 @@ -2129,7 +2125,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 endif - if ((CS%u_face_mask(i-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + if ((CS%u_face_mask(I-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -2143,19 +2139,19 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val endif - if ((CS%u_face_mask(i,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + if ((CS%u_face_mask(I,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then ! right face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif - if ((CS%v_face_mask(i,j-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + if ((CS%v_face_mask(i,J-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then ! south face of the cell is at a stress boundary taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif - if ((CS%v_face_mask(i,j) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + if ((CS%v_face_mask(i,J) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then ! north face of the cell is at a stress boundary taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val @@ -2205,25 +2201,28 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then if ((i <= iec).and.(i >= isc)) then - if (CS%u_face_mask(i-1,j) == 3) then - CS%u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + if (CS%u_face_mask(I-1,j) == 3) then + CS%u_bdry_val(I-1,J-1) = (1 - ((G%geoLatBu(I-1,J-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & 1.5 * input_flux / input_thick - CS%u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + CS%u_bdry_val(I-1,J) = (1 - ((G%geoLatBu(I-1,J) - 0.5*G%len_lat)*2./G%len_lat)**2) * & 1.5 * input_flux / input_thick endif endif endif - !### What about v_shelf? if (.not.(new_sim)) then if (.not. G%symmetric) then - if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then - CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) - CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) endif - if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then - CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) - CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif endif endif @@ -2234,7 +2233,7 @@ end subroutine init_boundary_values subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & - ice_visc, float_cond, bathyT, basal_trac, dxdyh, G, US, is, ie, js, je, dens_ratio) + ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & @@ -2265,8 +2264,8 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas !! partly or fully covered by an ice-shelf real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law. The exact form and units depend on the - !! basal law exponent. [?] + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form + !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2274,11 +2273,8 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent. [L-2 ? ~> m-2 ?] + !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. ! and/or whether flow is "hybridized" - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: dxdyh !< The tracer cell area [L2 ~> m2] real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors @@ -2296,21 +2292,21 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas ! the linear action of the matrix on (u,v) with bilinear finite elements ! Phi has the form -! Phi(i,j,k,q) - applies to cell i,j +! Phi(k,q,i,j) - applies to cell i,j ! 3 - 4 ! | | ! 1 - 2 -! Phi(i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q -! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q +! Phi(2*k-1,q,i,j) gives d(Phi_k)/dx at quadrature point q +! Phi(2*k,q,i,j) gives d(Phi_k)/dy at quadrature point q ! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] integer :: iq, jq, iphi, jphi, i, j, ilq, jlq real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr ! ,Ucontr + real, dimension(2,2) :: Ucell, Vcell, Hcell, Usubcontr, Vsubcontr xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) @@ -2318,60 +2314,60 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas do iq=1,2 ; do jq=1,2 - uq = u_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & - u_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & - u_shlf(i,j) * xquad(iq) * xquad(jq) + uq = u_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + u_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & + u_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & + u_shlf(I,J) * xquad(iq) * xquad(jq) - vq = v_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & - v_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & - v_shlf(i,j) * xquad(iq) * xquad(jq) + vq = v_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + v_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & + v_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & + v_shlf(I,J) * xquad(iq) * xquad(jq) - ux = u_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - u_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - u_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - u_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) + ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - vx = v_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - v_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - v_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - v_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) + vx = v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - uy = u_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - u_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - u_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - u_shlf(i,j) * Phi(i,j,8,2*(jq-1)+iq) + uy = u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - vy = v_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - v_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - v_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - v_shlf(i,j) * Phi(i,j,8,2*(jq-1)+iq) + vy = v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) do iphi=1,2 ; do jphi=1,2 - if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + 0.25 * dxdyh(i,j) * ice_visc(i,j) * & - ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + if (umask(I-2+iphi,J-2+jphi) == 1) then + uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + 0.25 * ice_visc(i,j) * & + ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + 0.25 * dxdyh(i,j) * ice_visc(i,j) * & - ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + if (vmask(I-2+iphi,J-2+jphi) == 1) then + vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + 0.25 * ice_visc(i,j) * & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) endif if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & - 0.25 * basal_trac(i,j) * dxdyh(i,j) * uq * xquad(ilq) * xquad(jlq) + if (umask(I-2+iphi,J-2+jphi) == 1) then + uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & - 0.25 * basal_trac(i,j) * dxdyh(i,j) * vq * xquad(ilq) * xquad(jlq) + if (vmask(I-2+iphi,J-2+jphi) == 1) then + vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2380,15 +2376,15 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 - Ucell(:,:) = u_shlf(i-1:i,j-1:j) ; Vcell(:,:) = v_shlf(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, dxdyh(i,j), bathyT(i,j), & + Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) ; Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), bathyT(i,j), & dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi=1,2 - if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) + if (umask(I-2+iphi,J-2+jphi) == 1) then + uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) + if (vmask(I-2+iphi,J-2+jphi) == 1) then + vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2453,12 +2449,11 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! (corner) points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law. The exact form and units depend on the - !! basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form + !! and units depend on the basal law exponent. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent [L-2 ? ~> m-2 ?] + !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2499,39 +2494,38 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + if (CS%umask(I-2+iphi,J-2+jphi) == 1) then ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) vx = 0. vy = 0. - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + & + 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) - !### uq seems to be duplicated here. Why not uq**2? - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif - if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + if (CS%vmask(I-2+iphi,J-2+jphi) == 1) then vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) ux = 0. uy = 0. - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + & + 0.25 * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then vq = xquad(ilq) * xquad(jlq) - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2542,9 +2536,9 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), G%bathyT(i,j), dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi=1,2 - if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) + if (CS%umask(I-2+iphi,J-2+jphi) == 1) then + u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) + v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2578,8 +2572,8 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, do m=1,2 ; do n=1,2 ; do j=1,nsub ; do i=1,nsub ; do qx=1,2 ; do qy = 1,2 - hloc = Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,1,2,qx,qy)*H_node(1,2) + & - Phisub(i,j,2,1,qx,qy)*H_node(2,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2) + hloc = (Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2)) + & + (Phisub(i,j,1,2,qx,qy)*H_node(1,2) + Phisub(i,j,2,1,qx,qy)*H_node(2,1)) if (dens_ratio * hloc - bathyT > 0) then Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 @@ -2609,11 +2603,10 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the - !! basal law exponent. + !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent [L-2 ~> m-2] + !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2646,8 +2639,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, ! process this cell if any corners have umask set to non-dirichlet bdry. ! NOTE: vmask not considered, probably should be - if ((CS%umask(i-1,j-1) == 3) .OR. (CS%umask(i,j-1) == 3) .OR. & - (CS%umask(i-1,j) == 3) .OR. (CS%umask(i,j) == 3)) then + if ((CS%umask(I-1,J-1) == 3) .OR. (CS%umask(I,J-1) == 3) .OR. & + (CS%umask(I-1,J) == 3) .OR. (CS%umask(I,J) == 3)) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2656,58 +2649,58 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, do iq=1,2 ; do jq=1,2 - uq = CS%u_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & - CS%u_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & - CS%u_bdry_val(i,j) * xquad(iq) * xquad(jq) + uq = CS%u_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + CS%u_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & + CS%u_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & + CS%u_bdry_val(I,J) * xquad(iq) * xquad(jq) - vq = CS%v_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & - CS%v_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & - CS%v_bdry_val(i,j) * xquad(iq) * xquad(jq) + vq = CS%v_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + CS%v_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & + CS%v_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & + CS%v_bdry_val(I,J) * xquad(iq) * xquad(jq) - ux = CS%u_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - CS%u_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & - CS%u_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & - CS%u_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + ux = CS%u_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & + CS%u_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & + CS%u_bdry_val(I-1,J) * Phi(5,2*(jq-1)+iq) + & + CS%u_bdry_val(I,J) * Phi(7,2*(jq-1)+iq) - vx = CS%v_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - CS%v_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & - CS%v_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & - CS%v_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + vx = CS%v_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & + CS%v_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & + CS%v_bdry_val(I-1,J) * Phi(5,2*(jq-1)+iq) + & + CS%v_bdry_val(I,J) * Phi(7,2*(jq-1)+iq) - uy = CS%u_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - CS%u_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & - CS%u_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & - CS%u_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + uy = CS%u_bdry_val(I-1,J-1) * Phi(2,2*(jq-1)+iq) + & + CS%u_bdry_val(I,J-1) * Phi(4,2*(jq-1)+iq) + & + CS%u_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & + CS%u_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) - vy = CS%v_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - CS%v_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & - CS%v_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & - CS%v_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + vy = CS%v_bdry_val(I-1,J-1) * Phi(2,2*(jq-1)+iq) + & + CS%v_bdry_val(I,J-1) * Phi(4,2*(jq-1)+iq) + & + CS%v_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & + CS%v_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) do iphi=1,2 ; do jphi=1,2 ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) + if (CS%umask(I-2+iphi,J-2+jphi) == 1) then + u_bdry_contr(I-2+iphi,J-2+jphi) = u_bdry_contr(I-2+iphi,J-2+jphi) + & + 0.25 * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then - u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + u_bdry_contr(I-2+iphi,J-2+jphi) = u_bdry_contr(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif - if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then - v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & - 0.25 * G%areaT(i,j) * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) + if (CS%vmask(I-2+iphi,J-2+jphi) == 1) then + v_bdry_contr(I-2+iphi,J-2+jphi) = v_bdry_contr(I-2+iphi,J-2+jphi) + & + 0.25 * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then - v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + v_bdry_contr(I-2+iphi,J-2+jphi) = v_bdry_contr(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2721,12 +2714,12 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), G%bathyT(i,j), & dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi = 1,2 - if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + if (CS%umask(I-2+iphi,J-2+jphi) == 1) then + u_bdry_contr(I-2+iphi,J-2+jphi) = u_bdry_contr(I-2+iphi,J-2+jphi) + & Usubcontr(iphi,jphi) * basal_trac(i,j) endif - if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then - v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + if (CS%vmask(I-2+iphi,J-2+jphi) == 1) then + v_bdry_contr(I-2+iphi,J-2+jphi) = v_bdry_contr(I-2+iphi,J-2+jphi) + & Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo @@ -2739,15 +2732,15 @@ end subroutine apply_boundary_values !> Update depth integrated viscosity, based on horizontal strain rates, and also update the !! nonlinear part of the basal traction. subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe - !! the ice-shelf state - type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve ! so there is an "upper" and "lower" bilinear viscosity @@ -2782,12 +2775,12 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) vx = ((v_shlf(I,J) + v_shlf(I,J-1)) - (v_shlf(I-1,J) + v_shlf(I-1,J-1))) / (2*G%dxT(i,j)) uy = ((u_shlf(I,J) + u_shlf(I-1,J)) - (u_shlf(I,J-1) + u_shlf(I-1,J-1))) / (2*G%dyT(i,j)) vy = ((v_shlf(I,J) + v_shlf(I-1,J)) - (v_shlf(I,J-1) + v_shlf(I-1,J-1))) / (2*G%dyT(i,j)) - CS%ice_visc(i,j) = 0.5 * Visc_coef * ISS%h_shelf(i,j) * & + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = sqrt(umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) + unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) CS%basal_traction(i,j) = CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo @@ -3086,90 +3079,90 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face if (hmask(i,j) == 1) then - umask(i-1:i,j-1:j) = 1. - vmask(i-1:i,j-1:j) = 1. + umask(I-1:I,j-1:j) = 1. + vmask(I-1:I,j-1:j) = 1. do k=0,1 - select case (int(CS%u_face_mask_bdry(i-1+k,j))) + select case (int(CS%u_face_mask_bdry(I-1+k,j))) case (3) - umask(i-1+k,j-1:j)=3. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=3. + umask(I-1+k,J-1:J)=3. + vmask(I-1+k,J-1:J)=0. + u_face_mask(I-1+k,j)=3. case (2) - u_face_mask(i-1+k,j)=2. + u_face_mask(I-1+k,j)=2. case (4) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=4. + umask(I-1+k,J-1:J)=0. + vmask(I-1+k,J-1:J)=0. + u_face_mask(I-1+k,j)=4. case (0) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=0. + umask(I-1+k,J-1:J)=0. + vmask(I-1+k,J-1:J)=0. + u_face_mask(I-1+k,j)=0. case (1) ! stress free x-boundary - umask(i-1+k,j-1:j)=0. + umask(I-1+k,J-1:J)=0. case default end select enddo do k=0,1 - select case (int(CS%v_face_mask_bdry(i,j-1+k))) + select case (int(CS%v_face_mask_bdry(i,J-1+k))) case (3) - vmask(i-1:i,j-1+k)=3. - umask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=3. + vmask(I-1:I,J-1+k)=3. + umask(I-1:I,J-1+k)=0. + v_face_mask(i,J-1+k)=3. case (2) - v_face_mask(i,j-1+k)=2. + v_face_mask(i,J-1+k)=2. case (4) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=4. + umask(I-1:I,J-1+k)=0. + vmask(I-1:I,J-1+k)=0. + v_face_mask(i,J-1+k)=4. case (0) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - u_face_mask(i,j-1+k)=0. + umask(I-1:I,J-1+k)=0. + vmask(I-1:I,J-1+k)=0. + v_face_mask(i,J-1+k)=0. case (1) ! stress free y-boundary - vmask(i-1:i,j-1+k)=0. + vmask(I-1:I,J-1+k)=0. case default end select enddo - !if (CS%u_face_mask_bdry(i-1,j) >= 0) then !left boundary - ! u_face_mask(i-1,j) = CS%u_face_mask_bdry(i-1,j) - ! umask(i-1,j-1:j) = 3. - ! vmask(i-1,j-1:j) = 0. + !if (CS%u_face_mask_bdry(I-1,j) >= 0) then ! Western boundary + ! u_face_mask(I-1,j) = CS%u_face_mask_bdry(I-1,j) + ! umask(I-1,J-1:J) = 3. + ! vmask(I-1,J-1:J) = 0. !endif - !if (j_off+j == gjsc+1) then !bot boundary - ! v_face_mask(i,j-1) = 0. - ! umask(i-1:i,j-1) = 0. - ! vmask(i-1:i,j-1) = 0. - !elseif (j_off+j == gjec) then !top boundary - ! v_face_mask(i,j) = 0. - ! umask(i-1:i,j) = 0. - ! vmask(i-1:i,j) = 0. + !if (j_off+j == gjsc+1) then ! SoutherN boundary + ! v_face_mask(i,J-1) = 0. + ! umask(I-1:I,J-1) = 0. + ! vmask(I-1:I,J-1) = 0. + !elseif (j_off+j == gjec) then ! Northern boundary + ! v_face_mask(i,J) = 0. + ! umask(I-1:I,J) = 0. + ! vmask(I-1:I,J) = 0. !endif if (i < G%ied) then if ((hmask(i+1,j) == 0) & .OR. (hmask(i+1,j) == 2)) then !right boundary or adjacent to unfilled cell - u_face_mask(i,j) = 2. + u_face_mask(I,j) = 2. endif endif if (i > G%isd) then if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then !adjacent to unfilled cell - u_face_mask(i-1,j) = 2. + u_face_mask(I-1,j) = 2. endif endif if (j > G%jsd) then if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then !adjacent to unfilled cell - v_face_mask(i,j-1) = 2. + v_face_mask(i,J-1) = 2. endif endif @@ -3435,7 +3428,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil real :: u_face ! Zonal velocity at a face, positive if out {L T-1 ~> m s-1] - real :: flux_diff_cell, phi + real :: flux_diff, phi character (len=1) :: debug_str @@ -3472,18 +3465,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - flux_diff_cell = 0 + flux_diff = 0 ! 1ST DO LEFT FACE - if (CS%u_face_mask(i-1,j) == 4.) then + if (CS%u_face_mask(I-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) * & + flux_diff = flux_diff + G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) * & CS%t_bdry_val(i-1,j) / G%areaT(i,j) else ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available @@ -3491,32 +3484,32 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j)* time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) else ! h(i-1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i-2) is not - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(-1) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(-1) endif elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) endif endif endif @@ -3526,32 +3519,32 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! get u-velocity at center of right face - if (CS%u_face_mask(i+1,j) == 4.) then + if (CS%u_face_mask(I+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) *& + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) *& CS%t_bdry_val(i+1,j) / G%areaT(i,j) else - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (stencil(1) - phi * (stencil(1)-stencil(0))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(1) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(1) endif @@ -3560,44 +3553,44 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(1))/2) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(i+2) is not - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) endif endif endif - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff endif elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i-1,j) * & + u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) + flux_enter(i,j,1) = ABS(u_face) * G%dyCu(I-1,j) * time_step * CS%t_bdry_val(i-1,j) * & CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(i-1,j) == 4.) then - flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j)*CS%t_bdry_val(i-1,j) + elseif (CS%u_face_mask(I-1,j) == 4.) then + flux_enter(i,j,1) = G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j)*CS%t_bdry_val(i-1,j) endif if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i+1,j)* & + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + flux_enter(i,j,2) = ABS(u_face) * G%dyCu(I,j) * time_step * CS%t_bdry_val(i+1,j)* & CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(i+1,j) == 4.) then - flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) * CS%t_bdry_val(i+1,j) + elseif (CS%u_face_mask(I+1,j) == 4.) then + flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) * CS%t_bdry_val(i+1,j) endif ! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -3665,7 +3658,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] - real :: flux_diff_cell, phi + real :: flux_diff, phi character(len=1) :: debug_str is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3697,18 +3690,18 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft h_after_vflux(i,j) = h_after_uflux(i,j) stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 + flux_diff = 0 ! 1ST DO south FACE - if (CS%v_face_mask(i,j-1) == 4.) then + if (CS%v_face_mask(i,J-1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) * & + flux_diff = flux_diff + G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) * & CS%t_bdry_val(i,j-1)/ G%areaT(i,j) else ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + v_face = 0.5 * (CS%v_shelf(I-1,J-1) + CS%v_shelf(I,J-1)) if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available @@ -3716,32 +3709,31 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) else ! h(j-1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(-1) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(-1) endif elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) - !### The G%dyT(i,j) below needs to be G%dxCv(i,J) if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) endif endif @@ -3752,42 +3744,42 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! NEXT DO north FACE - if (CS%v_face_mask(i,j+1) == 4.) then + if (CS%v_face_mask(i,J+1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) *& + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) *& CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (stencil(1) - phi * (stencil(1)-stencil(0))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(1) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(1) endif elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(1))/2) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) endif endif @@ -3795,24 +3787,24 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft endif - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j-1)* & + v_face = 0.5 * (CS%v_shelf(I-1,J-1) + CS%v_shelf(I,J-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxCv(i,J-1) * time_step * CS%t_bdry_val(i,j-1)* & CS%thickness_bdry_val(i,j-1) - elseif (CS%v_face_mask(i,j-1) == 4.) then - flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1)*CS%t_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,J-1) == 4.) then + flux_enter(i,j,3) = G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1)*CS%t_bdry_val(i,J-1) endif if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j+1)* & + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) + flux_enter(i,j,4) = ABS(v_face) * G%dxCv(i,J) * time_step * CS%t_bdry_val(i,j+1)* & CS%thickness_bdry_val(i,j+1) - elseif (CS%v_face_mask(i,j+1) == 4.) then - flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1)*CS%t_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,J+1) == 4.) then + flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1)*CS%t_bdry_val(i,j+1) endif ! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then From 6fd0edf2f89687381e54e7c861d5487873d01740 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Mar 2020 10:23:10 -0400 Subject: [PATCH 119/137] (*)Fixed spatial index errors in ice_shelf_advect Corrected spatial indexing errors associated with open boundary condition fluxes in the four ice_shelf_advect routines. This could change answers in some cases, but these errors seem likely to lead to segmentation faults in such cases, so it is entirely possible that this code has never been exercised. Also revised the directional nomenclature in some comments. All answers are bitwise identical in the MOM6-examples test cases, but it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 113 +++++++++++------------ 1 file changed, 56 insertions(+), 57 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 0aae1d35f8..8fa014c57f 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -709,10 +709,10 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! ###Perhaps flux_enter should be changed into u-face and v-face ! ###fluxes, which can then be used in halo updates, etc. ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED @@ -1329,10 +1329,10 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -1433,11 +1433,11 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! NEXT DO RIGHT FACE - ! get u-velocity at center of right face + ! get u-velocity at center of east face - if (CS%u_face_mask(I+1,j) == 4.) then + if (CS%u_face_mask(I,j) == 4.) then - flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) / G%areaT(i,j) + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) / G%areaT(i,j) else @@ -1502,8 +1502,8 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) flux_enter(i,j,2) = ABS(u_face) * G%dyCu(I,j) * time_step * CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(I+1,j) == 4.) then - flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) + elseif (CS%u_face_mask(I,j) == 4.) then + flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) endif if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -1556,10 +1556,10 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -1661,9 +1661,9 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! NEXT DO north FACE - if (CS%v_face_mask(i,J+1) == 4.) then + if (CS%v_face_mask(i,J) == 4.) then - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) / G%areaT(i,j) + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) / G%areaT(i,j) else @@ -1718,8 +1718,8 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%u_shelf(I-1,J) + CS%u_shelf(I,J)) flux_enter(i,j,4) = ABS(v_face) * G%dxCv(i,J) * time_step * CS%thickness_bdry_val(i,j+1) - elseif (CS%v_face_mask(i,J+1) == 4.) then - flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) + elseif (CS%v_face_mask(i,J) == 4.) then + flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) endif if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then @@ -1766,10 +1766,10 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -2042,7 +2042,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) else sx = 0 endif - elseif ((i+i_off) == giec) then ! at right computational bdry + elseif ((i+i_off) == giec) then ! at east computational bdry if (ISS%hmask(i-1,j) == 1) then sx = (S(i,j)-S(i-1,j))/dxh else @@ -2140,7 +2140,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif if ((CS%u_face_mask(I,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then - ! right face of the cell is at a stress boundary + ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif @@ -3145,9 +3145,8 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face !endif if (i < G%ied) then - if ((hmask(i+1,j) == 0) & - .OR. (hmask(i+1,j) == 2)) then - !right boundary or adjacent to unfilled cell + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + ! east boundary or adjacent to unfilled cell u_face_mask(I,j) = 2. endif endif @@ -3278,10 +3277,10 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! ###Perhaps flux_enter should be changed into u-face and v-face ! ###fluxes, which can then be used in halo updates, etc. ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED @@ -3411,10 +3410,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -3517,11 +3516,11 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! NEXT DO RIGHT FACE - ! get u-velocity at center of right face + ! get u-velocity at center of eastern face - if (CS%u_face_mask(I+1,j) == 4.) then + if (CS%u_face_mask(I,j) == 4.) then - flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) *& + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) *& CS%t_bdry_val(i+1,j) / G%areaT(i,j) else @@ -3589,18 +3588,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) flux_enter(i,j,2) = ABS(u_face) * G%dyCu(I,j) * time_step * CS%t_bdry_val(i+1,j)* & CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(I+1,j) == 4.) then - flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) * CS%t_bdry_val(i+1,j) + elseif (CS%u_face_mask(I,j) == 4.) then + flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) * CS%t_bdry_val(i+1,j) endif ! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left + ! the front without having to call pass_var - if cell is empty and cell to west ! is ice-covered then this cell will become partly covered ! hmask(i,j) = 2 ! elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left + ! the front without having to call pass_var - if cell is empty and cell to west ! is ice-covered then this cell will become partly covered ! hmask(i,j) = 2 @@ -3641,10 +3640,10 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -3700,7 +3699,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft CS%t_bdry_val(i,j-1)/ G%areaT(i,j) else - ! get u-velocity at center of left face + ! get u-velocity at center of west face v_face = 0.5 * (CS%v_shelf(I-1,J-1) + CS%v_shelf(I,J-1)) if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available @@ -3744,13 +3743,13 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! NEXT DO north FACE - if (CS%v_face_mask(i,J+1) == 4.) then + if (CS%v_face_mask(i,J) == 4.) then - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) *& + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) *& CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else - ! get u-velocity at center of right face + ! get u-velocity at center of east face v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available @@ -3803,18 +3802,18 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) flux_enter(i,j,4) = ABS(v_face) * G%dxCv(i,J) * time_step * CS%t_bdry_val(i,j+1)* & CS%thickness_bdry_val(i,j+1) - elseif (CS%v_face_mask(i,J+1) == 4.) then - flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1)*CS%t_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,J) == 4.) then + flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J)*CS%t_bdry_val(i,j+1) endif ! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left + ! the front without having to call pass_var - if cell is empty and cell to west ! is ice-covered then this cell will become partly covered ! hmask(i,j) = 2 ! elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing the - ! front without having to call pass_var - if cell is empty and cell to left is + ! front without having to call pass_var - if cell is empty and cell to west is ! ice-covered then this cell will become partly covered ! hmask(i,j) = 2 ! endif From 5fb71b1072c6e4311e1b1d82e6a36991583cfe32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Mar 2020 15:08:21 -0400 Subject: [PATCH 120/137] +Revised routines in ice_shelf_advect Extensively revised the ice_shelf_advect_thickness and shelf_advance_front routines, avoiding the use of the flux_enter as arguments between routines. Also folded the area into the definition of CS%basal_traction. Also corrected distributed spelling errors and added local variables to avoid repetitious complicated index constructs. All answers are bitwise identical in the MOM6-examples test cases, but it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1008 ++++++---------------- 1 file changed, 281 insertions(+), 727 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8fa014c57f..f9d272b16e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -49,7 +49,7 @@ module MOM_ice_shelf_dynamics !! not vertices. Will represent boundary conditions on computational boundary !! (or permanent boundary between fast-moving and near-stagnant ice !! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, - !! 3=inhomogeneous dirichlet boundary, 4=flux boundary: at these faces a flux + !! 3=inhomogeneous Dirichlet boundary, 4=flux boundary: at these faces a flux !! will be specified which will override velocities; a homogeneous velocity !! condition will be specified (this seems to give the solver less difficulty) real, pointer, dimension(:,:) :: v_face_mask => NULL() !< A mask for velocity boundary conditions on the C-grid @@ -60,7 +60,7 @@ module MOM_ice_shelf_dynamics !! through open boundary u-faces (where u_face_mask=4) [Z L T-1 ~> m2 s-1] real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]?? - ! needed where u_face_mask is equal to 4, similary for v_face_mask + ! needed where u_face_mask is equal to 4, similarly for v_face_mask real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) !! 1=normal node, 3=inhomogeneous boundary node, !! 0 - no flow node (will also get ice-free nodes) @@ -69,7 +69,7 @@ module MOM_ice_shelf_dynamics !! 0 - no flow node (will also get ice-free nodes) real, pointer, dimension(:,:) :: calve_mask => NULL() !< a mask to prevent the ice shelf front from !! advancing past its initial position (but it may retreat) - real, pointer, dimension(:,:) :: t_shelf => NULL() !< Veritcally integrated temperature in the ice shelf/stream, + real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. @@ -81,8 +81,8 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< The nonlinear part of "linearized" - !! basal stress [R Z T-1 ~> kg m-2 s-1]. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" + !! basal stress [R Z L2 T-1 ~> kg s-1]. !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. @@ -97,9 +97,9 @@ module MOM_ice_shelf_dynamics !! using the nonlinear elliptic equation, or 0 to update every timestep [T ~> s]. ! DNGoldberg thinks this should be done no more often than about once a day ! (maybe longer) because it will depend on ocean values that are averaged over - ! this time interval, and solving for the equiliabrated flow will begin to lose + ! this time interval, and solving for the equilibrated flow will begin to lose ! meaning if it is done too frequently. - real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last updated [T ~> s]. + real :: elapsed_velocity_time !< The elapsed time since the ice velocities were last updated [T ~> s]. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. @@ -135,7 +135,7 @@ module MOM_ice_shelf_dynamics real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that - !! deterimnes when to stop the conguage gradient iterations. + !! determines when to stop the conjugate gradient iterations. real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, !! that sets when to stop the iterative velocity solver integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver @@ -161,6 +161,13 @@ module MOM_ice_shelf_dynamics end type ice_shelf_dyn_CS +!> A container for loop bounds +type :: loop_bounds_type ; private + !>@{ Loop bounds + integer :: ish, ieh, jsh, jeh + !>@} +end type loop_bounds_type + contains !> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) @@ -257,7 +264,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & "Volume integrated Glens law ice viscosity", "kg m2 s-1") call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & - "Coefficient of basal traction", "kg m-2 s-1") + "The area integrated basal traction coefficient", "kg s-1") endif end subroutine register_ice_shelf_dyn_restarts @@ -397,8 +404,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "If true, do not allow an ice shelf where prohibited by a mask.", & default=.false.) endif - call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & - CS%min_thickness_simple_calve, & + call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & "Min thickness rule for the VERY simple calving law",& units="m", default=0.0, scale=US%m_to_Z) @@ -590,7 +596,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) end subroutine initialize_diagnostic_fields !> This function returns the global maximum advective timestep that can be taken based on the current -!! ice velocities. Because it involves finding a global minimum, it can be suprisingly expensive. +!! ice velocities. Because it involves finding a global minimum, it can be surprisingly expensive. function ice_time_step_CFL(CS, ISS, G) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe @@ -703,36 +709,17 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! The flux overflows are included here. That is because they will be used to advect 3D scalars ! into partial cells - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern neighbor: flux_enter(:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell - ! through the 4 cell boundaries [Z L2 ~> m3]. - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + type(loop_bounds_type) :: LB + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec, stencil isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter(:,:,:) = 0.0 + + uh_ice(:,:) = 0.0 + vh_ice(:,:) = 0.0 h_after_uflux(:,:) = 0.0 h_after_vflux(:,:) = 0.0 @@ -742,14 +729,20 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) endif ; enddo ; enddo - call ice_shelf_advect_thickness_x(CS, G, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, flux_enter) + stencil = 2 + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + if (LB%jsh < jsd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, uh_ice) ! call enable_averages(time_step, Time, CS%diag) ! call pass_var(h_after_uflux, G%domain) ! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) ! call disable_averaging(CS%diag) - call ice_shelf_advect_thickness_y(CS, G, time_step, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_uflux, h_after_vflux, vh_ice) ! call enable_averages(time_step, Time, CS%diag) ! call pass_var(h_after_vflux, G%domain) @@ -763,7 +756,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) enddo if (CS%moving_shelf_front) then - call shelf_advance_front(CS, ISS, G, flux_enter) + call shelf_advance_front(CS, ISS, G, ISS%hmask, uh_ice, vh_ice) if (CS%min_thickness_simple_calve > 0.0) then call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & CS%min_thickness_simple_calve) @@ -777,7 +770,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) !call disable_averaging(CS%diag) - !call change_thickness_using_melt(ISS, G, US%T_to_s*time_step, fluxes, CS%density_ice) + !call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) @@ -811,7 +804,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell verticies [m-1]. + ! quadrature points surrounding the cell vertices [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] character(2) :: iternum @@ -834,11 +827,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) - ! this is to determine which cells contain the grounding line, - ! the criterion being that the cell is ice-covered, with some nodes - ! floating and some grounded - ! floatation condition is estimated by assuming topography is cellwise constant - ! and H is bilinear in a cell; floating where rho_i/rho_w * H_node + D is nonpositive + ! This is to determine which cells contain the grounding line, the criterion being that the cell + ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by + ! assuming topography is cellwise constant and H is bilinear in a cell; floating where + ! rho_i/rho_w * H_node - D is negative ! need to make this conditional on GL interp @@ -879,8 +871,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call pass_var(CS%ice_visc, G%domain) call pass_var(CS%basal_traction, G%domain) - ! makes sure basal stress is only applied when it is supposed to be - + ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo @@ -932,7 +923,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call pass_var(CS%basal_traction, G%domain) ! makes sure basal stress is only applied when it is supposed to be - do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo @@ -940,8 +930,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, & - rhoi_rhow, u_bdry_cont, v_bdry_cont) + CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 @@ -1034,12 +1023,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the - !! iterations have converged to the specified tolerence + !! iterations have converged to the specified tolerance integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -1307,9 +1296,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H end subroutine ice_shelf_solve_inner -subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after_uflux, uh_ice) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are @@ -1319,437 +1309,167 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z L2 ~> m3]. + real, dimension(SZDIB_(G),SZDJ_(G)), & + intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells - ! if there is an input bdry condition, the thickness there will be set in initialization - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. - real :: u_face ! Zonal velocity at a face, positive if out {L Z-1 ~> m s-1] - real :: flux_diff + integer :: i, j + integer :: ish, ieh, jsh, jeh + real :: u_face ! Zonal velocity at a face [L Z-1 ~> m s-1] + real :: h_face ! Thickness at a face for transport [Z ~> m] real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] - character (len=1) :: debug_str - - is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do j=jsd+1,jed-1 - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - - stencil(:) = -1. -! if (i+i_off == G%domain%nihalo+G%domain%nihalo) - do i=is,ie - - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - if (i+i_off == G%domain%nihalo+1) then - at_west_bdry=.true. +! is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec +! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed +! i_off = G%idg_offset ; j_off = G%jdg_offset + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition + ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC + + do j=jsh,jeh ; do I=ish-1,ieh + if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. + uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) + elseif ((hmask(i,j)==1) .or. (hmask(i+1,j) == 1)) then + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. + + if (u_face > 0) then + if (hmask(i,j) == 3) then ! This is a open boundary inflow from the west + h_face = CS%thickness_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be eastward flow through this face. + if ((hmask(i-1,j) == 1) .and. (hmask(i+1,j) == 1)) then + slope_lim = slope_limiter(h0(i,j)-h0(i-1,j), h0(i+1,j)-h0(i,j)) + ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. + h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i+1,j)) else - at_west_bdry=.false. + h_face = h0(i,j) endif - - if (i+i_off == G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. + endif + else + if (hmask(i+1,j) == 3) then ! This is a open boundary inflow from the east + h_face = CS%thickness_bdry_val(i+1,j) + elseif (hmask(i+1,j) == 1) then + if ((hmask(i,j) == 1) .and. (hmask(i+2,j) == 1)) then + slope_lim = slope_limiter(h0(i+1,j)-h0(i,j), h0(i+2,j)-h0(i+1,j)) + h_face = h0(i+1,j) - slope_lim * 0.5 * (h0(i+1,j)-h0(i,j)) else - at_east_bdry=.false. - endif - - if (hmask(i,j) == 1) then - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff = 0 - - ! 1ST DO LEFT FACE - - if (CS%u_face_mask(I-1,j) == 4.) then - - flux_diff = flux_diff + G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) / G%areaT(i,j) - - else - - ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) - - if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a - ! thickness bdry condition, and the stencil contains it - stencil (-1) = CS%thickness_bdry_val(i-1,j) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(-1) / G%areaT(i,j) - - elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid - slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & - (stencil(-1) - slope_lim * (stencil(-1)-stencil(0))/2) - - else ! h(i-1) is valid (o.w. flux would most likely be out of cell) but h(i-2) is not - - flux_diff = flux_diff + ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * stencil(-1) - endif - - elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) - - else - flux_diff = flux_diff - ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * stencil(0) - - if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of east face - - if (CS%u_face_mask(I,j) == 4.) then - - flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) / G%areaT(i,j) - - else - - u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) - - if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - - if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a - ! thickness bdry condition, and the stencil contains it - - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step * stencil(1) / G%areaT(i,j) - - elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid - - slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(1) - slope_lim * (stencil(1)-stencil(0))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff = flux_diff + ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * stencil(1) - - endif - - elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - - if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - - slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (stencil(0)-stencil(1))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff = flux_diff - ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * stencil(0) - - if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff - - endif - - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) - flux_enter(i,j,1) = ABS(u_face) * G%dyCu(I-1,j) * time_step * CS%thickness_bdry_val(i-1,j) - elseif (CS%u_face_mask(I-1,j) == 4.) then - flux_enter(i,j,1) = G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) - endif - - if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) - flux_enter(i,j,2) = ABS(u_face) * G%dyCu(I,j) * time_step * CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(I,j) == 4.) then - flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) - endif - - if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - - endif - + h_face = h0(i+1,j) endif - endif + endif - enddo ! i loop - + uh_ice(I,j) = time_step * G%dyCu(I,j) * u_face * h_face + else + uh_ice(I,j) = 0.0 endif + enddo ; enddo - enddo ! j loop + do j=jsh,jeh ; do i=ish,ieh + if (hmask(i,j) /= 3) & + h_after_uflux(i,j) = h0(i,j) + (uh_ice(I-1,j) - uh_ice(I,j)) * G%IareaT(i,j) + + ! Update the masks of cells that have gone from no ice to partial ice. + if ((hmask(i,j) == 0) .and. ((uh_ice(I-1,j) > 0.0) .or. (uh_ice(I,j) < 0.0))) hmask(i,j) = 2 + enddo ; enddo end subroutine ice_shelf_advect_thickness_x -subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) +subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after_vflux, vh_ice) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h_after_uflux !< The ice shelf thicknesses after - !! the zonal mass fluxes [Z ~> m]. + intent(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z L2 ~> m3]. + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells - ! if there is an input bdry condition, the thickness there will be set in initialization - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. - real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] - real :: flux_diff + integer :: i, j + integer :: ish, ieh, jsh, jeh + real :: v_face ! Pseudo-meridional velocity at a face [L Z-1 ~> m s-1] + real :: h_face ! Thickness at a face for transport [Z ~> m] real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] - character(len=1) :: debug_str - - is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - do i=isd+2,ied-2 - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then ! based on Mehmet's code - only if btw east & west boundaries - stencil(:) = -1 + ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition + ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC - do j=js,je + do J=jsh-1,jeh ; do i=ish,ieh + if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. + vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) + elseif ((hmask(i,j)==1) .or. (hmask(i,j+1) == 1)) then - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) + h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. - if (j+j_off == G%domain%njhalo+1) then - at_south_bdry=.true. + if (v_face > 0) then + if (hmask(i,j) == 3) then ! This is a open boundary inflow from the south + h_face = CS%thickness_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be northtward flow through this face. + if ((hmask(i,j-1) == 1) .and. (hmask(i,j+1) == 1)) then + slope_lim = slope_limiter(h0(i,j)-h0(i,j-1), h0(i,j+1)-h0(i,j)) + ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. + h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i,j+1)) else - at_south_bdry=.false. + h_face = h0(i,j) endif - - if (j+j_off == G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. + endif + else + if (hmask(i,j+1) == 3) then ! This is a open boundary inflow from the north + h_face = CS%thickness_bdry_val(i,j+1) + elseif (hmask(i,j+1) == 1) then + if ((hmask(i,j) == 1) .and. (hmask(i,j+2) == 1)) then + slope_lim = slope_limiter(h0(i,j+1)-h0(i,j), h0(i,j+2)-h0(i,j+1)) + h_face = h0(i,j+1) - slope_lim * 0.5 * (h0(i,j+1)-h0(i,j)) else - at_north_bdry=.false. + h_face = h0(i,j+1) endif + endif + endif - if (hmask(i,j) == 1) then - h_after_vflux(i,j) = h_after_uflux(i,j) - - stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff = 0 - - ! 1ST DO south FACE - - if (CS%v_face_mask(i,J-1) == 4.) then - - flux_diff = flux_diff + G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) / G%areaT(i,j) - - else - - ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(I-1,J-1) + CS%v_shelf(I,J-1)) - - if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a - ! thickness bdry condition, and the stencil contains it - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(-1) / G%areaT(i,j) - - elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid - - slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(-1) - slope_lim * (stencil(-1)-stencil(0))/2) - - else ! h(j-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j-2) is not - flux_diff = flux_diff + ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * stencil(-1) - endif - - elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) - else - flux_diff = flux_diff - ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * stencil(0) - - if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (CS%v_face_mask(i,J) == 4.) then - - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) / G%areaT(i,j) - - else - - ! get v-velocity at center of north face - v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) - - if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - - if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a - ! thickness bdry condition, and the stencil contains it - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) - elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid - slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(1) - slope_lim * (stencil(1)-stencil(0))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(1) - endif - - elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (stencil(0)-stencil(1))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) - if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff - - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then - v_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I,J-1)) - flux_enter(i,j,3) = ABS(v_face) * G%dxCv(i,J-1) * time_step * CS%thickness_bdry_val(i,j-1) - elseif (CS%v_face_mask(i,J-1) == 4.) then - flux_enter(i,j,3) = G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) - endif - - if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then - v_face = 0.5 * (CS%u_shelf(I-1,J) + CS%u_shelf(I,J)) - flux_enter(i,j,4) = ABS(v_face) * G%dxCv(i,J) * time_step * CS%thickness_bdry_val(i,j+1) - elseif (CS%v_face_mask(i,J) == 4.) then - flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) - endif + vh_ice(i,J) = time_step * G%dxCv(i,J) * v_face * h_face + else + vh_ice(i,J) = 0.0 + endif + enddo ; enddo - if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - hmask(i,j) = 2 - elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - hmask(i,j) = 2 - endif + do j=jsh,jeh ; do i=ish,ieh + if (hmask(i,j) /= 3) & + h_after_vflux(i,j) = h0(i,j) + (vh_ice(i,J-1) - vh_ice(i,J)) * G%IareaT(i,j) - endif - endif - enddo ! j loop - endif - enddo ! i loop + ! Update the masks of cells that have gone from no ice to partial ice. + if ((hmask(i,j) == 0) .and. ((vh_ice(i,J-1) > 0.0) .or. (vh_ice(i,J) < 0.0))) hmask(i,j) = 2 + enddo ; enddo end subroutine ice_shelf_advect_thickness_y -subroutine shelf_advance_front(CS, ISS, G, flux_enter) +subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z L2 ~> m3]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJ_(G)), & + intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary @@ -1758,7 +1478,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) - ! most likely there will only be one "overflow". if not, though, a pass_var of all relevant variables + ! most likely there will only be one "overflow". If not, though, a pass_var of all relevant variables ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through ! many iterations @@ -1788,7 +1508,8 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message integer, dimension(4) :: mapi, mapj, new_partial -! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the + ! cell through the 4 cell boundaries [Z L2 ~> m3]. real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace ! An updated ice volume flux into the ! cell through the 4 cell boundaries [Z L2 ~> m3]. @@ -1796,6 +1517,15 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) i_off = G%idg_offset ; j_off = G%jdg_offset iter_count = 0 ; iter_flag = 1 + flux_enter(:,:,:) = 0.0 + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 2)) then + flux_enter(i,j,1) = max(uh_ice(I-1,j), 0.0) + flux_enter(i,j,2) = max(-uh_ice(I,j), 0.0) + flux_enter(i,j,3) = max(vh_ice(i,J-1), 0.0) + flux_enter(i,j,4) = max(-vh_ice(i,J), 0.0) + endif + enddo ; enddo mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 @@ -2242,7 +1972,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(SZDI_(G),SZDJ_(G),8,4), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -2304,9 +2034,9 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - integer :: iq, jq, iphi, jphi, i, j, ilq, jlq + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell, Vcell, Hcell, Usubcontr, Vsubcontr + real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) @@ -2344,84 +2074,73 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - do iphi=1,2 ; do jphi=1,2 - if (umask(I-2+iphi,J-2+jphi) == 1) then - uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + 0.25 * ice_visc(i,j) * & + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) - endif - if (vmask(I-2+iphi,J-2+jphi) == 1) then - vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + 0.25 * ice_visc(i,j) * & - ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) + if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) - endif if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - - if (umask(I-2+iphi,J-2+jphi) == 1) then - uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) - endif - - if (vmask(I-2+iphi,J-2+jphi) == 1) then - vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) - endif - + if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) endif enddo ; enddo enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 - Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) ; Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), bathyT(i,j), & - dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi=1,2 - if (umask(I-2+iphi,J-2+jphi) == 1) then - uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) - endif - if (vmask(I-2+iphi,J-2+jphi) == 1) then - vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) - endif - enddo ; enddo + Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, bathyT(i,j), dens_ratio, Usub, Vsub) + + if (umask(I-1,J-1)==1) uret(I-1,J-1) = uret(I-1,J-1) + Usub(1,1) * basal_trac(i,j) + if (umask(I-1,J) == 1) uret(I-1,J) = uret(I-1,J) + Usub(1,2) * basal_trac(i,j) + if (umask(I,J-1) == 1) uret(I,J-1) = uret(I,J-1) + Usub(2,1) * basal_trac(i,j) + if (umask(I,J) == 1) uret(I,J) = uret(I,J) + Usub(2,2) * basal_trac(i,j) + + if (vmask(I-1,J-1)==1) vret(I-1,J-1) = vret(I-1,J-1) + Vsub(1,1) * basal_trac(i,j) + if (vmask(I-1,J) == 1) vret(I-1,J) = vret(I-1,J) + Vsub(1,2) * basal_trac(i,j) + if (vmask(I,J-1) == 1) vret(I,J-1) = vret(I,J-1) + Vsub(2,1) * basal_trac(i,j) + if (vmask(I,J) == 1) vret(I,J) = vret(I,J) + Vsub(2,2) * basal_trac(i,j) endif endif ; enddo ; enddo end subroutine CG_action -subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) +subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, Vcontr) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] - real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater [nondim] - real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction basal stress [L3 T-1 ~> m3 s-1]. - real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction basal stress [L3 T-1 ~> m3 s-1]. + !! of seawater [nondim] + real, dimension(2,2), intent(out) :: Ucontr !< The areal average of u-velocities where the ice shelf + !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. + real, dimension(2,2), intent(out) :: Vcontr !< The areal average of v-velocities where the ice shelf + !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. - real :: subarea ! A sub-cell area [L2 ~> m2] + real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-cell ice thickness [Z ~> m] integer :: nsub, i, j, qx, qy, m, n nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) + subarea = 1.0 / (nsub**2) do n=1,2 ; do m=1,2 Ucontr(m,n) = 0.0 ; Vcontr(m,n) = 0.0 do qy=1,2 ; do qx=1,2 ; do j=1,nsub ; do i=1,nsub hloc = (Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,2,2,qx,qy)*H(2,2)) + & (Phisub(i,j,1,2,qx,qy)*H(1,2) + Phisub(i,j,2,1,qx,qy)*H(2,1)) - if (dens_ratio * hloc - bathyT > 0) then ! if (.true.) then + if (dens_ratio * hloc - bathyT > 0) then Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & ((Phisub(i,j,1,1,qx,qy) * U(1,1) + Phisub(i,j,2,2,qx,qy) * U(2,2)) + & (Phisub(i,j,1,2,qx,qy) * U(1,2) + Phisub(i,j,2,1,qx,qy) * U(2,1))) @@ -2471,12 +2190,12 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! returns the diagonal entries of the matrix for a Jacobi preconditioning - integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] real :: uq, vq real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell, Usubcontr, Vsubcontr + real, dimension(2,2) :: Hcell, sub_ground + integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2489,56 +2208,54 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 - + do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (CS%umask(I-2+iphi,J-2+jphi) == 1) then + if (CS%umask(Itgt,Jtgt) == 1) then ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) vx = 0. vy = 0. - u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + & + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) - u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif - if (CS%vmask(I-2+iphi,J-2+jphi) == 1) then + if (CS%vmask(Itgt,Jtgt) == 1) then vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) ux = 0. uy = 0. - v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + & + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) if (float_cond(i,j) == 0) then vq = xquad(ilq) * xquad(jlq) - v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif enddo ; enddo ; enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), G%bathyT(i,j), dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi=1,2 - if (CS%umask(I-2+iphi,J-2+jphi) == 1) then - u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) - v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) + call CG_diagonal_subgrid_basal(Phisub, Hcell, G%bathyT(i,j), dens_ratio, sub_ground) + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + if (CS%umask(Itgt,Jtgt) == 1) then + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2546,38 +2263,35 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, end subroutine matrix_diagonal -subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) +subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_grnd) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] - real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction diagonal elements from basal stress [L2 ~> m2]. - real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction diagonal elements from basal stress [L2 ~> m2]. + real, dimension(2,2), intent(out) :: sub_grnd !< The weighted fraction of the sub-cell where the ice shelf + !! is grounded [nondim] ! bathyT = cellwise-constant bed elevation - real :: subarea ! The local sub-region area [L2 ~> m2] + real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-region thickness [Z ~> m] integer :: nsub, i, j, k, l, qx, qy, m, n nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) + subarea = 1.0 / (nsub**2) + sub_grnd(:,:) = 0.0 do m=1,2 ; do n=1,2 ; do j=1,nsub ; do i=1,nsub ; do qx=1,2 ; do qy = 1,2 hloc = (Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2)) + & (Phisub(i,j,1,2,qx,qy)*H_node(1,2) + Phisub(i,j,2,1,qx,qy)*H_node(2,1)) if (dens_ratio * hloc - bathyT > 0) then - Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 + sub_grnd(m,n) = sub_grnd(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 endif enddo ; enddo ; enddo ; enddo ; enddo ; enddo @@ -2624,11 +2338,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(8,4) :: Phi real, dimension(2) :: xquad - integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] real :: area real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr + integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2679,50 +2393,49 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, CS%v_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & CS%v_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) - do iphi=1,2 ; do jphi=1,2 + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (CS%umask(I-2+iphi,J-2+jphi) == 1) then - u_bdry_contr(I-2+iphi,J-2+jphi) = u_bdry_contr(I-2+iphi,J-2+jphi) + & + if (CS%umask(Itgt,Jtgt) == 1) then + u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then - u_bdry_contr(I-2+iphi,J-2+jphi) = u_bdry_contr(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) + u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif - if (CS%vmask(I-2+iphi,J-2+jphi) == 1) then - v_bdry_contr(I-2+iphi,J-2+jphi) = v_bdry_contr(I-2+iphi,J-2+jphi) + & + if (CS%vmask(Itgt,Jtgt) == 1) then + v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & 0.25 * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then - v_bdry_contr(I-2+iphi,J-2+jphi) = v_bdry_contr(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) + v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif enddo ; enddo enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 Ucell(:,:) = CS%u_bdry_val(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_bdry_val(i-1:i,j-1:j) Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), G%bathyT(i,j), & + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%bathyT(i,j), & dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi = 1,2 - if (CS%umask(I-2+iphi,J-2+jphi) == 1) then - u_bdry_contr(I-2+iphi,J-2+jphi) = u_bdry_contr(I-2+iphi,J-2+jphi) + & - Usubcontr(iphi,jphi) * basal_trac(i,j) - endif - if (CS%vmask(I-2+iphi,J-2+jphi) == 1) then - v_bdry_contr(I-2+iphi,J-2+jphi) = v_bdry_contr(I-2+iphi,J-2+jphi) + & - Vsubcontr(iphi,jphi) * basal_trac(i,j) - endif - enddo ; enddo + + if (CS%umask(I-1,J-1)==1) u_bdry_contr(I-1,J-1) = u_bdry_contr(I-1,J-1) + Usubcontr(1,1) * basal_trac(i,j) + if (CS%umask(I-1,J) == 1) u_bdry_contr(I-1,J) = u_bdry_contr(I-1,J) + Usubcontr(1,2) * basal_trac(i,j) + if (CS%umask(I,J-1) == 1) u_bdry_contr(I,J-1) = u_bdry_contr(I,J-1) + Usubcontr(2,1) * basal_trac(i,j) + if (CS%umask(I,J) == 1) u_bdry_contr(I,J) = u_bdry_contr(I,J) + Usubcontr(2,2) * basal_trac(i,j) + + if (CS%vmask(I-1,J-1)==1) v_bdry_contr(I-1,J-1) = v_bdry_contr(I-1,J-1) + Vsubcontr(1,1) * basal_trac(i,j) + if (CS%vmask(I-1,J) == 1) v_bdry_contr(I-1,J) = v_bdry_contr(I-1,J) + Vsubcontr(1,2) * basal_trac(i,j) + if (CS%vmask(I,J-1) == 1) v_bdry_contr(I,J-1) = v_bdry_contr(I,J-1) + Vsubcontr(2,1) * basal_trac(i,j) + if (CS%vmask(I,J) == 1) v_bdry_contr(I,J) = v_bdry_contr(I,J) + Vsubcontr(2,2) * basal_trac(i,j) endif endif endif ; enddo ; enddo @@ -2781,7 +2494,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) - CS%basal_traction(i,j) = CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo enddo @@ -2863,7 +2576,7 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, intent(out) :: area !< The quadrilateral cell area [L2 ~> m2]. ! X and Y must be passed in the form @@ -2932,7 +2645,7 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) integer, intent(in) :: i !< The i-index in the grid to work on. integer, intent(in) :: j !< The j-index in the grid to work on. real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. ! This subroutine calculates the gradients of bilinear basis elements that ! that are centered at the vertices of the cell. The values are calculated at @@ -3256,7 +2969,7 @@ end subroutine ice_shelf_dyn_end subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe - !! the ice-shelf state + !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< The time step for this update [T ~> s]. @@ -3271,49 +2984,24 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! The flux overflows are included here. That is because they will be used to advect 3D scalars ! into partial cells - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern neighbor: flux_enter(:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell - ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: t_bd, Tsurf - real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. + real :: Tsurf ! Surface air temperature. This is hard coded but should be an input argument. + real :: adot ! A surface heat exchange coefficient divided by the heat capacity of + ! ice [R Z T-1 degC-1 ~> kg m-2 s-1 degC-1]. ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later - adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s + adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s * CS%density_ice Tsurf = -20.0 isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter(:,:,:) = 0.0 th_after_uflux(:,:) = 0.0 th_after_vflux(:,:) = 0.0 do j=jsd,jed ; do i=isd,ied - t_bd = CS%t_bdry_val(i,j) ! if (ISS%hmask(i,j) > 1) then if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then CS%t_shelf(i,j) = CS%t_bdry_val(i,j) @@ -3321,6 +3009,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) enddo ; enddo do j=jsd,jed ; do i=isd,ied + ! Convert the averge temperature to a depth integrated temperature. TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) enddo ; enddo @@ -3331,52 +3020,35 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) - call ice_shelf_advect_temp_x(CS, G, time_step, ISS%hmask, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + call ice_shelf_advect_temp_x(CS, G, time_step, ISS%hmask, TH, th_after_uflux) + call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux) - do j=jsd,jed - do i=isd,ied -! if (ISS%hmask(i,j) == 1) then + do j=jsc,jec ; do i=isc,iec + ! Convert the integrated temperature back to the average temperature. +! if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if (ISS%h_shelf(i,j) > 0.0) then + CS%t_shelf(i,j) = th_after_vflux(i,j) / ISS%h_shelf(i,j) + else + CS%t_shelf(i,j) = -10.0 + endif +! endif + + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then if (ISS%h_shelf(i,j) > 0.0) then - CS%t_shelf(i,j) = th_after_vflux(i,j)/(ISS%h_shelf(i,j)) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + & + time_step*(adot*Tsurf - melt_rate(i,j)*ISS%tfreeze(i,j))/(CS%density_ice*ISS%h_shelf(i,j)) else + ! the ice is about to melt away in this case set thickness, area, and mask to zero + ! NOTE: not mass conservative, should maybe scale salt & heat flux for this cell CS%t_shelf(i,j) = -10.0 + CS%tmask(i,j) = 0.0 endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_bdry_val(i,j) -! if (ISS%hmask(i,j) > 1) then - if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then - CS%t_shelf(i,j) = t_bd -! CS%t_shelf(i,j) = -15.0 - endif - enddo - enddo - - do j=jsc,jec - do i=isc,iec - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - if (ISS%h_shelf(i,j) > 0.0) then - !### Why is the hard-coded code uncommented and the plausible one commented out? -! CS%t_shelf(i,j) = CS%t_shelf(i,j) + & -! time_step*(adot*Tsurf - US%R_to_kg_m3*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) - CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step * & - (adot*Tsurf - ((3.0/(365.0*86400.0))*US%m_to_Z*US%T_to_s)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) - else - ! the ice is about to melt away - ! in this case set thickness, area, and mask to zero - ! NOTE: not mass conservative - ! should maybe scale salt & heat flux for this cell - - CS%t_shelf(i,j) = -10.0 - CS%tmask(i,j) = 0.0 - endif - endif - enddo - enddo + elseif (ISS%hmask(i,j) == 0) then + CS%t_shelf(i,j) = -10.0 + elseif ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) + endif + enddo ; enddo call pass_var(CS%t_shelf, G%domain) call pass_var(CS%tmask, G%domain) @@ -3388,7 +3060,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) end subroutine ice_shelf_temp -subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step !< The time step for this update [T ~> s]. @@ -3400,28 +3072,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z L2 ~> degC m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells - ! if there is an input bdry condition, the thickness there will be set in initialization - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied integer :: i_off, j_off logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry @@ -3506,10 +3160,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f else flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) - - if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) - endif endif endif endif @@ -3555,17 +3205,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(1))/2) - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not + else ! h(i+1) is valid (o.w. flux would most likely be out of cell) but h(i+2) is not flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(0) - if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - - flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) - endif - endif endif @@ -3574,37 +3217,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f endif - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(I-1,J-1) + CS%u_shelf(I-1,J)) - flux_enter(i,j,1) = ABS(u_face) * G%dyCu(I-1,j) * time_step * CS%t_bdry_val(i-1,j) * & - CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(I-1,j) == 4.) then - flux_enter(i,j,1) = G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j)*CS%t_bdry_val(i-1,j) - endif - - if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) - flux_enter(i,j,2) = ABS(u_face) * G%dyCu(I,j) * time_step * CS%t_bdry_val(i+1,j)* & - CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(I,j) == 4.) then - flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) * CS%t_bdry_val(i+1,j) - endif - -! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to west - ! is ice-covered then this cell will become partly covered -! hmask(i,j) = 2 -! elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to west - ! is ice-covered then this cell will become partly covered -! hmask(i,j) = 2 - -! endif - endif endif @@ -3617,7 +3229,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f end subroutine ice_shelf_advect_temp_x -subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) +subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step !< The time step for this update [T ~> s]. @@ -3630,28 +3242,10 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z L2 ~> degC m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells - ! if there is an input bdry condition, the thickness there will be set in initialization - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied integer :: i_off, j_off logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry @@ -3730,11 +3324,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) - - if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) - endif - endif endif @@ -3744,7 +3333,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! NEXT DO north FACE if (CS%v_face_mask(i,J) == 4.) then - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) *& CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else @@ -3777,9 +3365,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) - if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) - endif endif endif @@ -3787,37 +3372,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft endif h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff - - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then - v_face = 0.5 * (CS%v_shelf(I-1,J-1) + CS%v_shelf(I,J-1)) - flux_enter(i,j,3) = ABS(v_face) * G%dxCv(i,J-1) * time_step * CS%t_bdry_val(i,j-1)* & - CS%thickness_bdry_val(i,j-1) - elseif (CS%v_face_mask(i,J-1) == 4.) then - flux_enter(i,j,3) = G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1)*CS%t_bdry_val(i,J-1) - endif - - if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then - v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) - flux_enter(i,j,4) = ABS(v_face) * G%dxCv(i,J) * time_step * CS%t_bdry_val(i,j+1)* & - CS%thickness_bdry_val(i,j+1) - elseif (CS%v_face_mask(i,J) == 4.) then - flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J)*CS%t_bdry_val(i,j+1) - endif - -! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to west - ! is ice-covered then this cell will become partly covered - ! hmask(i,j) = 2 - ! elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the - ! front without having to call pass_var - if cell is empty and cell to west is - ! ice-covered then this cell will become partly covered -! hmask(i,j) = 2 -! endif - endif endif enddo ! j loop From f2a668a4e04fc4eaa69bc04fc6ccec76eb08ae00 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Mar 2020 17:55:00 -0400 Subject: [PATCH 121/137] Fixed minor syntax errors in 4 dOyxgen comments --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index f9d272b16e..ca8faf55f3 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1310,7 +1310,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. real, dimension(SZDIB_(G),SZDJ_(G)), & - intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization @@ -1393,7 +1393,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJB_(G)), & - intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization @@ -1467,9 +1467,9 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, dimension(SZDIB_(G),SZDJ_(G)), & - intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJB_(G)), & - intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> m3] ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary From 6ce3dd9b730a2f75884d9159cd48ad6895eccc73 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 30 Mar 2020 09:58:02 -0600 Subject: [PATCH 122/137] 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.) From 7fb8f55555574a2faa5f9801beb6add833eae8bc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 14:48:22 -0400 Subject: [PATCH 123/137] Flipped the sign convention for wT_flux Changed the sign conventions of the internal variables wT_flux, wB_flux, dT_ustar and dS_ustar in shelf_calc_flux to follow the vertical flux sign conventions in the rest of the MOM6 code. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d05631c621..6fa7aef94e 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -245,19 +245,18 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness !! to the molecular boundary layer thickness [nondim]. - !### THESE ARE CURRENTLY POSITIVE UPWARD. - real :: wT_flux !< The upward vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. - real :: wB_flux !< The upward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. + real :: wT_flux !< The downward vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. + real :: wB_flux !< The downward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 degC-1 ~> m s-2 degC-1]. real :: I_n_star ! [nondim] real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2] real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2] - real :: dT_ustar ! The difference between the ocean boundary layer temperature and the freezing - ! freezing point times the friction velocity [degC Z T-1 ~> degC m s-1] - real :: dS_ustar ! The difference between the ocean boundary layer salinity and the salinity - ! at the ice-ocean interface the friction velocity [ppt Z T-1 ~> ppt m s-1] + real :: dT_ustar ! The difference between the the freezing point and the ocean boundary layer + ! temperature times the friction velocity [degC Z T-1 ~> degC m s-1] + real :: dS_ustar ! The difference between the salinity at the ice-ocean interface and the ocean + ! boundary layer salinity times the friction velocity [ppt Z T-1 ~> ppt m s-1] real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] real :: Gam_turb ! [nondim] real :: Gam_mol_t, Gam_mol_s @@ -429,8 +428,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Determine the potential temperature at the ice-ocean interface. call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h - dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h + dT_ustar = (ISS%tfreeze(i,j) - state%sst(i,j)) * ustar_h + dS_ustar = (Sbdry(i,j) - state%sss(i,j)) * ustar_h ! First, determine the buoyancy flux assuming no effects of stability ! on the turbulence. Following H & J '99, this limit also applies @@ -449,7 +448,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wT_flux = dT_ustar * I_Gam_T wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - if (wB_flux > 0.0) then + if (wB_flux < 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent ! fluxes, and iteration is required. n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 @@ -458,7 +457,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! to the neutral thickness. ! hBL = n_star*hBL_neut ; hSub = 1/8*n_star*hBL - I_n_star = sqrt(1.0 + n_star_term * wB_flux) + I_n_star = sqrt(1.0 - n_star_term * wB_flux) dIns_dwB = 0.5 * n_star_term / I_n_star if (hBL_neut_h_molec > I_n_star**2) then Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + & @@ -484,18 +483,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux ! Find the root where wB_flux_new = wB_flux. - if (abs(wB_flux_new - wB_flux) < & - 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit + if (abs(wB_flux_new - wB_flux) < 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit - dDwB_dwB_in = -dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & - dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 + dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & + dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. ! ### SHOULD BOUNDS BE NEEDED? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif - ISS%tflux_ocn(i,j) = -RhoCp * wT_flux + ISS%tflux_ocn(i,j) = RhoCp * wT_flux exch_vel_t(i,j) = ustar_h * I_Gam_T exch_vel_s(i,j) = ustar_h * I_Gam_S @@ -1109,7 +1107,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". -#include "version_variable.h" +# include "version_variable.h" character(len=200) :: config character(len=200) :: IC_file,filename,inputdir character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. From 63fd8e1e85a9012ab89c09c94c6571da40113ae9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 17:38:25 -0400 Subject: [PATCH 124/137] +Added optional arg area to global_area_integral Added the new optional area argument to global_area_integral, to replace the area in G%areaT. All answers are bitwise identical. --- src/framework/MOM_spatial_means.F90 | 34 +++++++++++++++++++---------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 85d5ce452b..d4b687b0a5 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -47,14 +47,18 @@ function global_area_mean(var, G, scale) end function global_area_mean -!> Return the global area integral of a variable. This uses reproducing sums. -function global_area_integral(var, G, scale) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to integrate - real, optional, intent(in) :: scale !< A rescaling factor for the variable - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: global_area_integral - +!> Return the global area integral of a variable, by default using the masked area from the +!! grid, but an alternate could be used instead. This uses reproducing sums. +function global_area_integral(var, G, scale, area) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate + real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including + !! any required masking [L2 ~> m2]. + real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -62,9 +66,15 @@ function global_area_integral(var, G, scale) scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale tmpForSumming(:,:) = 0. - do j=js,je ; do i=is, ie - tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) - enddo ; enddo + if (present(area)) then + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (scalefac * area(i,j)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) + enddo ; enddo + endif global_area_integral = reproducing_sum(tmpForSumming) end function global_area_integral @@ -96,7 +106,7 @@ function global_layer_mean(var, h, G, GV, scale) global_temp_scalar = reproducing_sum(tmpForSumming,sums=scalarij) global_weight_scalar = reproducing_sum(weight,sums=weightij) - do k=1, nz + do k=1,nz global_layer_mean(k) = scalarij(k) / weightij(k) enddo From 7121619b29982e37233be66141def8a85d4178c0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 17:55:37 -0400 Subject: [PATCH 125/137] (*)Use global_area_integral in add_shelf_flux Replaced calls to the non-reproducing routines sum_across_PES with calls to global_area_integral that uses the reproducing sums when compensating for the global mean fresh water fluxes in add_shelf_flux. This also includes rescaling the dimensions of mean_melt_flux to [R Z T-1]. This could change answers at roundoff in some cases with an interactive ice shelf and CONST_SEA_LEVEL=True, but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 44 +++++++++++++++++---------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6fa7aef94e..f9b397451c 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -45,7 +45,8 @@ module MOM_ice_shelf use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use MOM_coms, only : reproducing_sum, sum_across_PEs +use MOM_coms, only : reproducing_sum +use MOM_spatial_means, only : global_area_integral use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init @@ -877,20 +878,21 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: Irho0 !< The inverse of the mean density times unit conversion factors that !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. real :: frac_area !< The fractional area covered by the ice shelf [nondim]. - real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). - real :: shelf_mass1 !< Total ice shelf mass at current time (Time). real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- real :: asv1, asv2 !< and v-points [L2 ~> m2]. real :: fraz !< refreezing rate [kg m-2 s-1] - real :: mean_melt_flux !< spatial mean melt flux [kg s-1] or [kg m-2 s-1] at various points in the code. + real :: mean_melt_flux !< Spatial mean melt flux [R Z T-1 ~> kg m-2 s-1] real :: sponge_area !< total area of sponge region [m2] real :: t0 !< The previous time (Time-dt) [s]. type(time_type) :: Time0!< The previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: in_sponge !< 1 where the property damping occurs, 0 otherwise [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] + real, dimension(SZDI_(G),SZDJ_(G)) :: delta_float_mass !< The change in the floating mass between + !! the two timesteps at (Time) and (Time-dt) [R Z ~> kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness [Z ~> m] !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask @@ -994,15 +996,13 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 - mean_melt_flux = 0.0; sponge_area = 0.0 do j=js,je ; do i=is,ie - frac_area = fluxes%frac_shelf_h(i,j) - if (frac_area > 0.0) & - mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%RZ_T_to_kg_m2s*US%L_to_m**2*ISS%area_shelf_h(i,j) !### These hard-coded limits need to be corrected. They are inappropriate here. if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - sponge_area = sponge_area + US%L_to_m**2*G%areaT(i,j) + in_sponge(i,j) = 1.0 + else + in_sponge(i,j) = 0.0 endif enddo ; enddo @@ -1027,20 +1027,18 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) last_mass_shelf(:,:) = last_h_shelf(:,:) * CS%density_ice endif - shelf_mass0 = 0.0; shelf_mass1 = 0.0 ! get total ice shelf mass at (Time-dt) and (Time), in kg do j=js,je ; do i=is,ie ! just floating shelf (0.1 is a threshold for min ocean thickness) if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then - shelf_mass0 = shelf_mass0 + US%RZ_to_kg_m2*US%L_to_m**2*(last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + US%RZ_to_kg_m2*US%L_to_m**2*(ISS%mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) + else + delta_float_mass(i,j) = 0.0 endif enddo ; enddo - call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) - delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step -! write(mesg,*) 'delta_mass_shelf = ', delta_mass_shelf -! call MOM_mesg(mesg,5) + delta_mass_shelf = US%kg_m2s_to_RZ_T*(global_area_integral(delta_float_mass, G, scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) / CS%time_step) else! first time step delta_mass_shelf = 0.0 endif @@ -1048,18 +1046,22 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) delta_mass_shelf = 0.0 endif - call sum_across_PEs(mean_melt_flux) - call sum_across_PEs(sponge_area) - ! average total melt flux over sponge area - mean_melt_flux = (mean_melt_flux+delta_mass_shelf) / sponge_area !kg/(m^2 s) + sponge_area = global_area_integral(in_sponge, G) + if (sponge_area > 0.0) then + mean_melt_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & + delta_mass_shelf ) / sponge_area + else + mean_melt_flux = 0.0 + endif ! apply fluxes do j=js,je ; do i=is,ie ! Note the following is hard coded for ISOMIP if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T*mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif From 3c3f72167b8b8e5da306021979bfc4c2697f08ed Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 21:45:40 -0400 Subject: [PATCH 126/137] (*+)Corrected bugs in 3-eqn ice shelf skin salinity Corrected several bugs in the 3-equation ice shelf skin salinity calculation, including renaming variables for greater clarity and using forms for the solutions to a quadratic equation that are accurate without amplifying roundoff errors. In addition, a new runtime parameter, SHELF_3EQ_GAMMA_S, is read and logged when SHELF_3EQ_GAMMA is true. This will change answers and the parameter_doc files with when a thermodynamically active ice shelf is used and SHELF_THREE_EQN is true, but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 106 +++++++++++++++++--------------- 1 file changed, 57 insertions(+), 49 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index f9b397451c..a4f6169844 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -26,7 +26,7 @@ module MOM_ice_shelf use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_time_manager, only : time_type, time_type_to_real, real_to_time +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling use MOM_variables, only : surface @@ -106,6 +106,7 @@ module MOM_ice_shelf real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation + real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. real :: col_thick_melt_threshold !< if the mixed layer is below this threshold, melt rate logical :: mass_from_file !< Read the ice shelf mass from a file every dt @@ -150,14 +151,13 @@ module MOM_ice_shelf !! interface. logical :: insulator !< If true, ice shelf is a perfect insulator logical :: const_gamma !< If true, gamma_T is specified by the user. - logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. - ! The following parameters are needed if find_salt_root = true - real :: lambda1 !< liquidus coeff. The freezing point at 0 pressure and 0 salinity [degC] - real :: lambda2 !< Partial derivative of freezing temperature with salinity [degC ppt-1] - real :: lambda3 !< Partial derivative of freezing temperature with pressure [degC Pa-1] + logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. + real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] + real :: dTFr_dS !< Partial derivative of freezing temperature with salinity [degC ppt-1] + real :: dTFr_dp !< Partial derivative of freezing temperature with pressure [degC Pa-1] !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -241,7 +241,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & Sbdry !< Salinities in the ocean at the interface with the ice shelf [ppt]. real :: Sbdry_it - real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! Variables used to find salt roots + real :: Sbdry1, Sbdry2 + real :: S_a, S_b, S_c ! Variables used to find salt roots real :: dS_it !< The interface salinity change during an iteration [ppt]. real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness @@ -391,26 +392,31 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec) if (CS%find_salt_root) then - ! read liquidus parameters - - !### This should be CS%lamda2! - S_a = CS%lambda1 * CS%Gamma_T_3EQ * CS%Cp - ! The value of 35.0 here should be a parameter? - !### This should be (CS%lambda1 + CS%lambda3*p_int(i) - state%sst(i,j)) - S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%lambda2 + CS%lambda3*p_int(i)- state%sst(i,j)) - & - CS%Lat_fusion * CS%Gamma_T_3EQ/35.0 - S_c = CS%Lat_fusion * (CS%Gamma_T_3EQ/35.0) * state%sss(i,j) - - !### Depending on the sign of S_b, one of these will be inaccurate! - ! if (S_b >= 0.0) then - Sbdry1 = (-S_b + SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) - ! Sbdry1 = 2*S_c / (S_b + SQRT(S_b*S_b - 4*S_a*S_c)) - Sbdry2 = (-S_b - SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) - ! else - ! Sbdry1 = (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) / (2.*S_a) - ! Sbdry2 = -2.*S_c / (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) - ! endif - Sbdry(i,j) = MAX(Sbdry1, Sbdry2) + ! Solve for the skin salinity using the linearized liquidus parameters and + ! balancing the turbulent fresh water flux in the near-boundary layer with + ! the net fresh water or salt added by melting: + ! (Cp/Lat_fusion)*Gamma_T_3Eq*(TFr_skin-T_ocn) = Gamma_S_3Eq*(S_skin-S_ocn)/S_skin + + ! S_a is always < 0.0 with a realistic expression for the freezing point. + S_a = CS%dTFr_dS * CS%Gamma_T_3EQ * CS%Cp + S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%TFr_0_0 + CS%dTFr_dp*p_int(i) - state%sst(i,j)) - & + CS%Lat_fusion * CS%Gamma_S_3EQ ! S_b Can take either sign, but is usually negative. + S_c = CS%Lat_fusion * CS%Gamma_S_3EQ * state%sss(i,j) ! Always >= 0 + + if (S_c == 0.0) then ! The solution for fresh water. + Sbdry(i,j) = 0.0 + elseif (S_a < 0.0) then ! This is the usual ocean case + if (S_b < 0.0) then ! This is almost always the case + Sbdry(i,j) = 2.0*S_c / (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) + else + Sbdry(i,j) = (S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) / (-2.*S_a) + endif + elseif ((S_a == 0.0) .and. (S_b < 0.0)) then ! It should be the case that S_b < 0. + Sbdry(i,j) = -S_c / S_b + else + call MOM_error(FATAL, "Impossible conditions found in 3-equation skin salinity calculation.") + endif + ! Safety check if (Sbdry(i,j) < 0.) then write(mesg,*) 'state%sss(i,j) = ',state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c @@ -439,7 +445,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%const_gamma) then ! if using a constant gamma_T ! note the different form, here I_Gam_T is NOT 1/Gam_T! I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + I_Gam_S = CS%Gamma_S_3EQ else Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) @@ -474,7 +480,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%const_gamma) then ! if using a constant gamma_T ! note the different form, here I_Gam_T is NOT 1/Gam_T! I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + I_Gam_S = CS%Gamma_S_3EQ else I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) @@ -883,11 +889,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- real :: asv1, asv2 !< and v-points [L2 ~> m2]. - real :: fraz !< refreezing rate [kg m-2 s-1] real :: mean_melt_flux !< Spatial mean melt flux [R Z T-1 ~> kg m-2 s-1] real :: sponge_area !< total area of sponge region [m2] - real :: t0 !< The previous time (Time-dt) [s]. - type(time_type) :: Time0!< The previous time (Time-dt) + type(time_type) :: dTime !< The time step as a time_type + type(time_type) :: Time0 !< The previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: in_sponge !< 1 where the property damping occurs, 0 otherwise [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] @@ -989,8 +994,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! This is needed for some of the ISOMIP+ experiments. if (CS%constant_sea_level) then - !### This code has lots of problems with hard coded constants and the use of - !### of non-reproducing sums. It needs to be refactored. -RWH + !### This code has problems with hard coded constants that need to be refactored. -RWH if (.not. associated(fluxes%salt_flux)) allocate(fluxes%salt_flux(ie,je)) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) @@ -1008,11 +1012,11 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%override_shelf_movement .and. CS%mass_from_file) then - t0 = time_type_to_real(CS%Time) - CS%time_step + dTime = real_to_time(CS%time_step) - ! just compute changes in mass after first time step - if (t0>0.0) then - Time0 = real_to_time(t0) + ! Compute changes in mass after at least one full time step + if (CS%Time > dTime) then + Time0 = CS%Time - dTime last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) ! This should only be done if time_interp_external did an update. @@ -1058,9 +1062,9 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! apply fluxes do j=js,je ; do i=is,ie - ! Note the following is hard coded for ISOMIP - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + if (in_sponge(i,j) > 0.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] + !### Why does mean_melt_flux need to be rescaled to get vprec? fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] @@ -1073,7 +1077,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif - endif !constant_sea_level + endif ! constant_sea_level end subroutine add_shelf_flux @@ -1238,9 +1242,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "If true, user specifies a constant nondimensional heat-transfer coefficient "//& "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed "//& " as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) - if (CS%const_gamma) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & - "Nondimensional heat-transfer coefficient.",default=2.2E-2, & - units="nondim.", fail_if_missing=.true.) + if (CS%const_gamma) then + call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & + "Nondimensional heat-transfer coefficient.", & + units="nondim", default=2.2e-2) + call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_S", CS%Gamma_S_3EQ, & + "Nondimensional salt-transfer coefficient.", & + default=CS%Gamma_T_3EQ/35.0, units="nondim") + endif call get_param(param_file, mdl, "ICE_SHELF_MASS_FROM_FILE", & CS%mass_from_file, "Read the mass of the "//& @@ -1252,14 +1261,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "is computed from a quadratic equation. Otherwise, the previous "//& "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. - call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%lambda1, & + call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DS", CS%lambda1, & !### This should be CS%lambda2! + call get_param(param_file, mdl, "DTFREEZE_DS", CS%dTFr_dS, & "this is the derivative of the freezing potential "//& - "temperature with salinity.", & - units="degC psu-1", default=-0.054, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DP", CS%lambda3, & + "temperature with salinity.", units="degC psu-1", default=-0.054, do_not_log=.true.) + call get_param(param_file, mdl, "DTFREEZE_DP", CS%dTFr_dp, & "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="degC Pa-1", default=0.0, do_not_log=.true.) From 880da802441d95b4a78c11f6ad89a2cafee56b11 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Mar 2020 12:04:34 -0400 Subject: [PATCH 127/137] (*+)Corrected a bug in setting ustar_shelf Corrected a bug in setting fluxes%ustar_shelf in shelf_calc_flux, that will change answers with an active ice shelf when UTIDE is nonzero. Also rescaled the units of utide in MOM_ice_shelf.F90 to [L T-1] and added a units argument to get_param calls for 5 ISOMIP or ice-shelf related variables. This commit can change answers and the parameter_doc files in some cases when a thermodynamically active ice shelf is used, but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 25 ++++++++++++------------- src/user/ISOMIP_initialization.F90 | 10 +++++----- 2 files changed, 17 insertions(+), 18 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a4f6169844..6eb82f15d5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -87,7 +87,7 @@ module MOM_ice_shelf type(ice_shelf_dyn_CS), pointer :: dCS => NULL() !< The control structure for the ice-shelf dynamics. real, pointer, dimension(:,:) :: & - utide => NULL() !< tidal velocity [m s-1] + utide => NULL() !< An unresolved tidal velocity [L T-1 ~> m s-1] real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. @@ -360,13 +360,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Iteratively determine a self-consistent set of fluxes, with the ocean ! salinity just below the ice-shelf as the variable that is being ! iterated for. - ! ### SHOULD USTAR_SHELF BE SET YET? - !### I think that CS%utide**1 should be CS%utide**2 - ! Also I think that if taux_shelf and tauy_shelf have been calculated by the + ! ### SHOULD USTAR_SHELF BE SET YET, or should it be set from taux_shelf & tauy_shelf? + ! I think that if taux_shelf and tauy_shelf have been calculated by the ! ocean stress calculation, they should be used here or later to set ustar_shelf. - RWH - fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s * & - sqrt(CS%cdrag*((state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**1))) + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & + sqrt(CS%cdrag*(US%m_s_to_L_T**2*(state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**2))) ustar_h = fluxes%ustar_shelf(i,j) @@ -495,7 +494,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. - ! ### SHOULD BOUNDS BE NEEDED? + ! ### SHOULD BOUNDS BE NEEDED IN THIS NEWTONS METHOD SOLVER? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif @@ -1121,7 +1120,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl integer :: wd_halos(2) logical :: read_TideAmp, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file - real :: utide + real :: utide ! A tidal velocity [L T-1 ~> m s-1] if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") @@ -1218,7 +1217,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & "Depth above which the melt is set to zero (it must be >= 0) "//& - "Default value won't affect the solution.", default=0.0, scale=US%m_to_Z) !###, units="m" + "Default value won't affect the solution.", units="m", default=0.0, scale=US%m_to_Z) if (CS%cutoff_depth < 0.) & call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") @@ -1342,11 +1341,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) TideAmp_file = trim(inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, G%domain, timelevel=1) + call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, G%domain, timelevel=1, scale=US%m_s_to_L_T) else call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0 , scale=US%m_s_to_L_T) CS%utide(:,:) = utide endif @@ -1443,10 +1442,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "ice sheet/shelf thickness mask" ,"none") endif - ! if (CS%active_shelf_dynamics) then !### Consider adding an ice shelf dynamics switch. + if (CS%active_shelf_dynamics) then ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics call register_ice_shelf_dyn_restarts(G, param_file, CS%dCS, CS%restart_CSp) - ! endif + endif !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file !if (.not. CS%solo_ice_sheet) then diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 1d14ff9cc5..aa7de04dac 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -172,14 +172,14 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates - call get_param(param_file, mdl, "ISOMIP_T_SUR",t_sur, & - 'Temperature at the surface (interface)', default=-1.9, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_T_SUR", t_sur, & + 'Temperature at the surface (interface)', units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - 'Salinity at the surface (interface)', default=33.8, do_not_log=just_read) + 'Salinity at the surface (interface)', units="ppt", default=33.8, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - 'Temperature at the bottom (interface)', default=-1.9, do_not_log=just_read) + 'Temperature at the bottom (interface)', units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot,& - 'Salinity at the bottom (interface)', default=34.55, do_not_log=just_read) + 'Salinity at the bottom (interface)', units="ppt", default=34.55, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. From 1a8c75aa66807801409cbe2130abd50c4f46458b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Mar 2020 20:21:08 -0400 Subject: [PATCH 128/137] (*+)Set ice shelf latent heat consistently Set the latent heat of fusion and the heat capacity of water used by the ice shelf code consistently with the rest of MOM6, including their default values. This changes answers in all cases with active ice shelf thermodynamics. Also corrected a scaling factor for Rho0 and added several new chksum calls. Also added units for 6 ISOMIP-related input variables, and reordered the calls for several ice shelf parameters to make sure they are all being set when needed. This changes the solutions and the MOM_parameter_doc files in an updated ISOMIP test case but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 68 +++++++++++-------- .../vertical/MOM_diabatic_aux.F90 | 4 +- src/user/ISOMIP_initialization.F90 | 24 +++---- 3 files changed, 54 insertions(+), 42 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6eb82f15d5..ab3d52c6ae 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -5,6 +5,7 @@ module MOM_ice_shelf ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_constants, only : hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -351,7 +352,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! DNG - to allow this everywhere Hml>0.0 allows for melting under grounded cells ! propose instead to allow where Hml > [some threshold] - + !### I do not know what the Hml flag adds; consider removing it. if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. & (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then @@ -961,6 +962,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) enddo ; enddo endif + if (CS%debug) then + call MOM_forcing_chksum("Before adding shelf fluxes", fluxes, G, CS%US, haloshift=0) + endif + do j=js,je ; do i=is,ie ; if (ISS%area_shelf_h(i,j) > 0.0) then frac_area = fluxes%frac_shelf_h(i,j) !### Should this be 1-frac_shelf_h? if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 @@ -986,6 +991,12 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor endif ; enddo ; enddo + if (CS%debug) then + call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s) + call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, scale=US%QRZ_T_to_W_m2) + call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) + endif + ! keep sea level constant by removing mass in the sponge ! region (via virtual precip, vprec). Apply additional ! salt/heat fluxes so that the resultant surface buoyancy @@ -1071,7 +1082,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) enddo ; enddo if (CS%debug) then - write(mesg,*) 'Mean melt flux (kg/(m^2 s)), dt = ', mean_melt_flux, CS%time_step + write(mesg,*) 'Mean melt flux (kg/(m^2 s)), dt = ', mean_melt_flux*US%RZ_T_to_kg_m2s, CS%time_step call MOM_mesg(mesg) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif @@ -1177,8 +1188,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB - !### This should be a run-time parameter that is read in consistently with MOM6 and SIS2. - CS%Lat_fusion = 3.34e5*US%J_kg_to_Q CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. call log_version(param_file, mdl, version, "") @@ -1208,6 +1217,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & "If true, use a thermodynamically interactive ice shelf.", & default=.false.) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%Lat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "SHELF_THREE_EQN", CS%threeeq, & "If true, use the three equation expression of "//& "consistency to calculate the fluxes at the ice-ocean "//& @@ -1223,25 +1234,36 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "CONST_SEA_LEVEL", CS%constant_sea_level, & "If true, apply evaporative, heat and salt fluxes in "//& - "the sponge region. This will avoid a large increase "//& + "the sponge region. This will avoid a large increase "//& "in sea level. This option is needed for some of the "//& "ISOMIP+ experiments (Ocean3 and Ocean4). "//& "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) - call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", & - CS%S0, "Surface salinity in the resoring region.", & - default=33.8, do_not_log=.true.) + call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & + "Surface salinity in the restoring region.", & + default=33.8, units='ppt', do_not_log=.true.) - call get_param(param_file, mdl, "ISOMIP_T_SUR_SPONGE", & - CS%T0, "Surface temperature in the resoring region.", & - default=-1.9, do_not_log=.true.) + call get_param(param_file, mdl, "ISOMIP_T_SUR_SPONGE", CS%T0, & + "Surface temperature in the restoring region.", & + default=-1.9, units='degC', do_not_log=.true.) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA", CS%const_gamma, & "If true, user specifies a constant nondimensional heat-transfer coefficient "//& - "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed "//& - " as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) - if (CS%const_gamma) then + "(GAMMA_T_3EQ), from which the default salt-transfer coefficient is set "//& + "as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) + if (CS%threeeq) then + call get_param(param_file, mdl, "SHELF_S_ROOT", CS%find_salt_root, & + "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) "//& + "is computed from a quadratic equation. Otherwise, the previous "//& + "interactive method to estimate Sbdry is used.", default=.false.) + else + call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & + "If SHELF_THREE_EQN is false, this the fixed turbulent "//& + "exchange velocity at the ice-ocean interface.", & + units="m s-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + endif + if (CS%const_gamma .or. CS%find_salt_root) then call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & "Nondimensional heat-transfer coefficient.", & units="nondim", default=2.2e-2) @@ -1254,11 +1276,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%mass_from_file, "Read the mass of the "//& "ice shelf (every time step) from a file.", default=.false.) - if (CS%threeeq) & - call get_param(param_file, mdl, "SHELF_S_ROOT", CS%find_salt_root, & - "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) "//& - "is computed from a quadratic equation. Otherwise, the previous "//& - "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & "this is the freezing potential temperature at "//& @@ -1272,24 +1289,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl units="degC Pa-1", default=0.0, do_not_log=.true.) endif - if (.not.CS%threeeq) & - call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & - "If SHELF_THREE_EQN is false, this the fixed turbulent "//& - "exchange velocity at the ice-ocean interface.", & - units="m s-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) - call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80, scale=US%m_to_Z*US%T_to_s**2) call get_param(param_file, mdl, "C_P", CS%Cp, & - "The heat capacity of sea water.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & - fail_if_missing=.true.) + "The heat capacity of sea water, approximated as a constant. "//& + "The default value is from the TEOS-10 definition of conservative temperature.", & + units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) !### MAKE THIS A SEPARATE PARAMETER. + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 343423a221..b17f6e4323 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -931,7 +931,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t real, dimension(max(nsw,1),SZI_(G),SZK_(G)) :: & opacityBand ! The opacity (inverse of the exponential absorption length) of each frequency ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] - real, dimension(maxGroundings) :: hGrounding + real, dimension(maxGroundings) :: hGrounding ! Thickness added by each grounding event [H ~> m or kg m-2] real :: Temp_in, Salin_in real :: g_Hconv2 ! A conversion factor for use in the TKE calculation ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. @@ -1380,7 +1380,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t do i = 1, min(numberOfGroundings, maxGroundings) call forcing_SinglePointPrint(fluxes,G,iGround(i),jGround(i),'applyBoundaryFluxesInOut (grounding)') write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & - G%geoLatT( iGround(i), jGround(i)) , hGrounding(i) + G%geoLatT( iGround(i), jGround(i)), hGrounding(i)*GV%H_to_m call MOM_error(WARNING, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& "Mass created. x,y,dh= "//trim(mesg), all_print=.true.) enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index aa7de04dac..ba8dc1162f 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -173,13 +173,13 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates call get_param(param_file, mdl, "ISOMIP_T_SUR", t_sur, & - 'Temperature at the surface (interface)', units="degC", default=-1.9, do_not_log=just_read) + "Temperature at the surface (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - 'Salinity at the surface (interface)', units="ppt", default=33.8, do_not_log=just_read) + "Salinity at the surface (interface)", units="ppt", default=33.8, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - 'Temperature at the bottom (interface)', units="degC", default=-1.9, do_not_log=just_read) + "Temperature at the bottom (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot,& - 'Salinity at the bottom (interface)', units="ppt", default=34.55, do_not_log=just_read) + "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -293,13 +293,13 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_SUR",t_sur, & - 'Temperature at the surface (interface)', default=-1.9, do_not_log=just_read) + "Temperature at the surface (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - 'Salinity at the surface (interface)', default=33.8, do_not_log=just_read) + "Salinity at the surface (interface)", units="ppt", default=33.8, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - 'Temperature at the bottom (interface)', default=-1.9, do_not_log=just_read) + "Temperature at the bottom (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & - 'Salinity at the bottom (interface)', default=34.55, do_not_log=just_read) + "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) call calculate_density(t_sur,s_sur,0.0,rho_sur,eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Density in the surface layer:', rho_sur @@ -481,16 +481,16 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) do_not_log=.true.) call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & - 'Surface salinity in sponge layer.', default=s_ref) ! units="ppt") + "Surface salinity in sponge layer.", units="ppt", default=s_ref) ! units="ppt") call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, & - 'Bottom salinity in sponge layer.', default=s_ref) ! units="ppt") + "Bottom salinity in sponge layer.", units="ppt", default=s_ref) ! units="ppt") call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, & - 'Surface temperature in sponge layer.', default=t_ref) ! units="degC") + "Surface temperature in sponge layer.", units="degC", default=t_ref) ! units="degC") call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, & - 'Bottom temperature in sponge layer.', default=t_ref) ! units="degC") + "Bottom temperature in sponge layer.", units="degC", default=t_ref) ! units="degC") T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 !; RHO(:,:,:) = 0.0 From 7e7082060df9840c5023e5efebb0f25b1f28ae5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Mar 2020 21:49:31 -0400 Subject: [PATCH 129/137] +Added units for 13 runtime parameters Added units arguments to the get_param calls for 13 runtime parameters and corrected spelling errors in the descriptions of 4 other parameters. All answers are bitwise identical, but this leads to changes in the MOM_parameter_doc files. --- .../MOM_surface_forcing_gfdl.F90 | 2 +- src/ALE/MOM_regridding.F90 | 2 +- src/core/MOM.F90 | 4 +- .../lateral/MOM_thickness_diffuse.F90 | 4 +- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 4 +- .../vertical/MOM_set_diffusivity.F90 | 46 +++++++------------ .../vertical/MOM_vert_friction.F90 | 4 +- src/tracer/MOM_neutral_diffusion.F90 | 3 +- src/tracer/advection_test_tracer.F90 | 8 ++-- src/user/adjustment_initialization.F90 | 6 +-- 11 files changed, 36 insertions(+), 49 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 3fd9ce7888..860ba90487 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1361,7 +1361,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) if (CS%restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index f73e6e304f..bc290b3f94 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -516,7 +516,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & "When interpolating potential density profiles we can add "//& "some artificial compressibility solely to make homogeneous "//& - "regions appear stratified.", default=0.) + "regions appear stratified.", units="nondim", default=0.) call set_regrid_params(CS, compress_fraction=tmpReal) endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 213f81a06e..073393f9e9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1806,7 +1806,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & "If true, water freezes if it gets too cold, and the "//& - "the accumulated heat deficit is returned in the "//& + "accumulated heat deficit is returned in the "//& "surface state. FRAZIL is only used if "//& "ENABLE_THERMODYNAMICS is true.", default=.false.) call get_param(param_file, "MOM", "DO_GEOTHERMAL", use_geothermal, & @@ -1888,7 +1888,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", CS%answers_2018, & "If true, use expressions for the surface properties that recover the answers "//& "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& - "at roundoff for non-Boussinsq cases.", default=default_2018_answers) + "at roundoff for non-Boussinesq cases.", default=default_2018_answers) call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & "If true, write the initial conditions to a file given "//& diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 98b56c1cc8..895418e6e4 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1840,7 +1840,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & "If true, use the streamfunction formulation of "//& "Ferrari et al., 2010, which effectively emphasizes "//& @@ -1849,7 +1849,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "FGNV_FILTER_SCALE", CS%FGNV_scale, & "A coefficient scaling the vertical smoothing term in the "//& "Ferrari et al., 2010, streamfunction formulation.", & - default=1., do_not_log=.not.CS%use_FGNV_streamfn) + units="nondim", default=1., do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_C_MIN", CS%FGNV_c_min, & "A minium wave speed used in the Ferrari et al., 2010, "//& "streamfunction formulation.", & diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index ebd5016855..7a0f517020 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -326,7 +326,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_fill, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 77407b6da1..0cbcf235de 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -2096,9 +2096,9 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "be used in single-column mode!", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & - "If true. use an older, dimensionally inconsistent estimate of the "//& + "If true, use an older, dimensionally inconsistent estimate of the "//& "derivative of diffusivity with energy in the Newton's method iteration. "//& - "The bug causes undercorrections when dz > 1m.", default=.true.) + "The bug causes undercorrections when dz > 1 m.", default=.true.) call get_param(param_file, mdl, "KAPPA_SHEAR_ALL_LAYER_TKE_BUG", CS%all_layer_TKE_bug, & "If true, report back the latest estimate of TKE instead of the time average "//& "TKE when there is mass in all layers. Otherwise always report the time "//& diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 3229a7bf80..3045639232 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1930,10 +1930,9 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The flux Richardson number where the stratification is "//& "large enough that N2 > omega2. The full expression for "//& "the Flux Richardson number is usually "//& - "FLUX_RI_MAX*N2/(N2+OMEGA2).", default=0.2) + "FLUX_RI_MAX*N2/(N2+OMEGA2).", units="nondim", default=0.2) call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", units="s-1", default=7.2921e-5, scale=US%T_to_s) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & @@ -1956,8 +1955,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & "A coefficient that is used to scale the penetration "//& "depth for turbulence below the base of the mixed layer. "//& - "This is only used if ML_RADIATION is true.", units="nondim", & - default=0.2) + "This is only used if ML_RADIATION is true.", units="nondim", default=0.2) call get_param(param_file, mdl, "ML_RAD_BUG", CS%ML_rad_bug, & "If true use code with a bug that reduces the energy available "//& "in the transition layer by a factor of the inverse of the energy "//& @@ -1966,8 +1964,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The maximum diapycnal diffusivity due to turbulence "//& "radiated from the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", & - units="m2 s-1", default=1.0e-3, & - scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-3, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & "The coefficient which scales MSTAR*USTAR^3 to obtain "//& "the energy available for mixing below the base of the "//& @@ -1976,8 +1973,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "ML_RAD_APPLY_TKE_DECAY", CS%ML_rad_TKE_decay, & "If true, apply the same exponential decay to ML_rad as "//& "is applied to the other surface sources of TKE in the "//& - "mixed layer code. This is only used if ML_RADIATION is true.", & - default=.true.) + "mixed layer code. This is only used if ML_RADIATION is true.", default=.true.) call get_param(param_file, mdl, "MSTAR", CS%mstar, & "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) @@ -2003,9 +1999,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& "law of the form c_drag*|u|*u. The velocity magnitude "//& - "may be an assumed value or it may be based on the "//& - "actual velocity in the bottommost HBBL, depending on "//& - "LINEAR_DRAG.", default=.true.) + "may be an assumed value or it may be based on the actual "//& + "velocity in the bottommost HBBL, depending on LINEAR_DRAG.", default=.true.) if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "The drag coefficient relating the magnitude of the "//& @@ -2046,8 +2041,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "If true, uses a simple estimate of Kd/TKE that will "//& "work for arbitrary vertical coordinates. If false, "//& "calculates Kd/TKE and bounds based on exact energetics "//& - "for an isopycnal layer-formulation.", & - default=.false.) + "for an isopycnal layer-formulation.", default=.false.) ! set params releted to the background mixing call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp) @@ -2055,8 +2049,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KV", CS%Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, & - fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the "//& @@ -2065,13 +2058,11 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, & - scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& - "diffusivity from TKE-based parameterizations, or a "//& - "negative value for no limit.", units="m2 s-1", default=-1.0, & - scale=US%m2_s_to_Z2_T) + "diffusivity from TKE-based parameterizations, or a negative "//& + "value for no limit.", units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T) if (CS%simple_TKE_to_Kd .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & @@ -2084,15 +2075,14 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "USER_CHANGE_DIFFUSIVITY", CS%user_change_diff, & - "If true, call user-defined code to change the diffusivity.", & - default=.false.) + "If true, call user-defined code to change the diffusivity.", default=.false.) call get_param(param_file, mdl, "DISSIPATION_MIN", CS%dissip_min, & "The minimum dissipation by which to determine a lower "//& @@ -2102,8 +2092,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The intercept when N=0 of the N-dependent expression "//& "used to set a minimum dissipation by which to determine "//& "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & - units="W m-3", default=0.0, & - scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) + units="W m-3", default=0.0, scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N1", CS%dissip_N1, & "The coefficient multiplying N, following Gargett, used to "//& "set a minimum dissipation by which to determine a lower "//& @@ -2155,9 +2144,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "Maximum salt diffusivity for salt fingering regime.", & default=1.e-4, units="m2 s-1", scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & - "Molecular viscosity for calculation of fluxes under "//& - "double-diffusive convection.", default=1.5e-6, units="m2 s-1", & - scale=US%m2_s_to_Z2_T) + "Molecular viscosity for calculation of fluxes under double-diffusive "//& + "convection.", default=1.5e-6, units="m2 s-1", scale=US%m2_s_to_Z2_T) ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index e3bc14955f..5a610095ce 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1573,8 +1573,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & default=.true.) call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", CS%answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions that do not use an arbitary "//& - "and hard-coded maximum viscous coupling coefficient between layers.", & + "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& + "hard-coded maximum viscous coupling coefficient between layers.", & default=default_2018_answers) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b3e75ccfad..7566142d0f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -145,8 +145,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & "The reference pressure (Pa) used for the derivatives of "//& "the equation of state. If negative (default), local "//& - "pressure is used.", & - default = -1.) + "pressure is used.", units="Pa", default = -1.) ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index e81003c0ff..82ea38f22c 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -99,13 +99,13 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ADVECTION_TEST_X_ORIGIN", CS%x_origin, & - "The x-coorindate of the center of the test-functions.", default=0.) + "The x-coordinate of the center of the test-functions.", units="same as geoLon", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_ORIGIN", CS%y_origin, & - "The y-coorindate of the center of the test-functions.", default=0.) + "The y-coordinate of the center of the test-functions.", units="same as geoLat", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_X_WIDTH", CS%x_width, & - "The x-width of the test-functions.", default=0.) + "The x-width of the test-functions.", units="same as geoLon", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_WIDTH", CS%y_width, & - "The y-width of the test-functions.", default=0.) + "The y-width of the test-functions.", units="same as geoLat", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_TRACER_IC_FILE", CS%tracer_IC_file, & "The name of a file from which to read the initial "//& "conditions for the tracers, or blank to initialize "//& diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index bb4102f215..e4816a1338 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -88,13 +88,13 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read units="1e-3", fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl,"FRONT_WAVE_AMP",front_wave_amp, & "Amplitude of trans-frontal wave perturbation", & - units="same as x,y",default=0., do_not_log=just_read) + units="same as x,y", default=0., do_not_log=just_read) call get_param(param_file, mdl,"FRONT_WAVE_LENGTH",front_wave_length, & "Wave-length of trans-frontal wave perturbation", & - units="same as x,y",default=0., do_not_log=just_read) + units="same as x,y", default=0., do_not_log=just_read) call get_param(param_file, mdl,"FRONT_WAVE_ASYM",front_wave_asym, & "Amplitude of frontal asymmetric perturbation", & - default=0., do_not_log=just_read) + units="same as x,y", default=0., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. From e88732c3eae3ee31a04bda1464e137651955f0e0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 08:32:30 -0400 Subject: [PATCH 130/137] (*)Do not use Hml>0 as an ice shelf melt filter Avoid using the criterion that Hml>0 as a filter of when ice shelf melt can occur. I am not aware of a good justification for this filter, and it seems to be an historical artefact. Removing it causes melting to start one time step earlier at the start of a run, giving apparently better answers. This changes the answers in cases with a thermodynamically active ice shelf, including an ISOMIP test case, but all answers in the MOM6-examples test suite are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index ab3d52c6ae..13dd8940a3 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -350,12 +350,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! but it won't make a difference otherwise. fluxes%ustar_shelf(i,j)= 0.0 - ! DNG - to allow this everywhere Hml>0.0 allows for melting under grounded cells - ! propose instead to allow where Hml > [some threshold] - !### I do not know what the Hml flag adds; consider removing it. if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (ISS%area_shelf_h(i,j) > 0.0) .and. & - (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo ) then if (CS%threeeq) then ! Iteratively determine a self-consistent set of fluxes, with the ocean @@ -602,8 +598,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) do j=js,je ; do i=is,ie if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (ISS%area_shelf_h(i,j) > 0.0) .and. & - (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then ! Set melt to zero above a cutoff pressure (CS%Rho0*CS%cutoff_depth*CS%g_Earth). ! This is needed for the ISOMIP test case. From e87c66427f66dd9d944c44e35ccdf09e174f2a64 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 08:50:23 -0400 Subject: [PATCH 131/137] (*)Removed rescaling from mean_melt_flux to vprec Removed inappropriate density ratio rescaling from the conversion of mean_melt_flux to fluxes%vprec when CONST_SEA_LEVEL is true. Both are cast as mass fluxes, not thicknesses fluxes, so this ratio is not needed. This will change answers in some regional cases with thermodynamically active ice shelves, but all answers in the MOM6-examples test suite are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 50 +++++++++++++++++---------------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 13dd8940a3..aa20a7ccb4 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -351,7 +351,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%ustar_shelf(i,j)= 0.0 if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo ) then + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then ! Iteratively determine a self-consistent set of fluxes, with the ocean @@ -485,13 +485,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wT_flux = dT_ustar * I_Gam_T wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - ! Find the root where wB_flux_new = wB_flux. - if (abs(wB_flux_new - wB_flux) < 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit + ! Find the root where wB_flux_new = wB_flux. Make the 1.0e-4 below into a parameter? + if (abs(wB_flux_new - wB_flux) < 1.0e-4*(abs(wB_flux_new) + abs(wB_flux))) exit dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 - ! This is Newton's method without any bounds. - ! ### SHOULD BOUNDS BE NEEDED IN THIS NEWTONS METHOD SOLVER? + ! This is Newton's method without any bounds. Should bounds be needed? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif @@ -500,13 +499,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) exch_vel_t(i,j) = ustar_h * I_Gam_T exch_vel_s(i,j) = ustar_h * I_Gam_S - !Calculate the heat flux inside the ice shelf. - - !vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). - ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) - !vertical adv/diff as in H+J 199, eqs (31) & (26)... - ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) - !If this approximation is not made, iterations are required... See H+J Fig 3. + ! Calculate the heat flux inside the ice shelf. + ! Vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). + ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) + ! vertical adv/diff as in H+J 1999, eqs (31) & (26)... + ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) + ! If this approximation is not made, iterations are required... See H+J Fig 3. if (ISS%tflux_ocn(i,j) >= 0.0) then ! Freezing occurs due to downward ocean heat flux, so zero iout ce heat flux. @@ -548,19 +546,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (dS_it < 0.0) then ! Sbdry is now the upper bound. if (Sb_max_set .and. (Sbdry(i,j) > Sb_max)) & - call MOM_error(FATAL,"shelf_calc_flux: Irregular iteration for Sbdry (max).") + call MOM_error(FATAL,"shelf_calc_flux: Irregular iteration for Sbdry (max).") Sb_max = Sbdry(i,j) ; dS_max = dS_it ; Sb_max_set = .true. else ! Sbdry is now the lower bound. if (Sb_min_set .and. (Sbdry(i,j) < Sb_min)) & - call MOM_error(FATAL, & - "shelf_calc_flux: Irregular iteration for Sbdry (min).") - Sb_min = Sbdry(i,j) ; dS_min = dS_it ; Sb_min_set = .true. + call MOM_error(FATAL, "shelf_calc_flux: Irregular iteration for Sbdry (min).") + Sb_min = Sbdry(i,j) ; dS_min = dS_it ; Sb_min_set = .true. endif ! dS_it < 0.0 if (Sb_min_set .and. Sb_max_set) then ! Use the false position method for the next iteration. - Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * & - (dS_min / (dS_min - dS_max)) + Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * (dS_min / (dS_min - dS_max)) else Sbdry(i,j) = Sbdry_it endif ! Sb_min_set @@ -569,7 +565,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif ! CS%find_salt_root enddo !it1 - ! Check for non-convergence and/or non-boundedness? + ! Check for non-convergence and/or non-boundedness? else ! In the 2-equation form, the mixed layer turbulent exchange velocity @@ -584,7 +580,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif - else !not shelf + elseif (ISS%area_shelf_h(i,j) > 0.0) then ! This is an ice-sheet, not a floating shelf. + ISS%tflux_ocn(i,j) = 0.0 + else ! There is no ice shelf or sheet here. ISS%tflux_ocn(i,j) = 0.0 endif @@ -598,7 +596,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) do j=js,je ; do i=is,ie if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then + (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then ! Set melt to zero above a cutoff pressure (CS%Rho0*CS%cutoff_depth*CS%g_Earth). ! This is needed for the ISOMIP test case. @@ -627,8 +625,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) write(mesg,*) "|melt| = ",fluxes%iceshelf_melt(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j call MOM_error(FATAL, "shelf_calc_flux: "//trim(mesg)) endif - endif ! area_shelf_h !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! + elseif (ISS%area_shelf_h(i,j) > 0.0) then + ! This is grounded ice, that could be modified to melt if a geothermal heat flux were used. + haline_driving(i,j) = 0.0 + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 + endif ! area_shelf_h enddo ; enddo ! i- and j-loops ! mass flux [kg s-1], part of ISOMIP diags. @@ -1069,8 +1072,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie if (in_sponge(i,j) > 0.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - !### Why does mean_melt_flux need to be rescaled to get vprec? - fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%vprec(i,j) = -mean_melt_flux fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif From fcb1e92a12eedd7315448a9a8c605e9da81e0b30 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 12:09:04 -0400 Subject: [PATCH 132/137] +Add optional arg to ice_shelf_min_thickness_calve Added a new optional argument, halo, to ice_shelf_min_thickness_calve to specify the range of indices over which to work. All answers are bitwise identical, but there is a new argument in a public interface. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 31 ++++++++++++++---------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index ca8faf55f3..be3ae1ecde 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1650,7 +1650,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) end subroutine shelf_advance_front !> Apply a very simple calving law using a minimum thickness rule -subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve) +subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve, halo) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by @@ -1658,20 +1658,25 @@ subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickn real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, intent(in) :: thickness_calve !< The thickness at which to trigger calving [Z ~> m]. + integer, optional, intent(in) :: halo !< The number of halo points to use. If not present, + !! work on the entire data domain. + integer :: i, j, is, ie, js, je - integer :: i,j + if (present(halo)) then + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + else + is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed + endif - do j=G%jsd,G%jed - do i=G%isd,G%ied -! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & -! (CS%ground_frac(i,j) == 0.0)) then - if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then - h_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask(i,j) = 0.0 - endif - enddo - enddo + do j=js,je ; do i=is,ie +! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & +! (CS%ground_frac(i,j) == 0.0)) then + if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo ; enddo end subroutine ice_shelf_min_thickness_calve From 04d5a83dcb93dce3bc22d7ceeeddaf303d203870 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 12:10:23 -0400 Subject: [PATCH 133/137] (*)Use a blend of ice-shelf and open water fluxes Use a blend of ice-shelf and open water fluxes when there is partial cover by an ice shelf. This will change answers in some cases with temporally evolving ice shelves, but all answers in the MOM6-examples test suite are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 74 +++++++++++++++++++-------------- 1 file changed, 42 insertions(+), 32 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index aa20a7ccb4..ea9162afc5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -881,7 +881,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! local variables real :: Irho0 !< The inverse of the mean density times unit conversion factors that !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. - real :: frac_area !< The fractional area covered by the ice shelf [nondim]. + real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. + real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. @@ -956,7 +957,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then do j=jsd,jed ; do i=isd,ied if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) * G%IareaT(i,j) + fluxes%frac_shelf_h(i,j) = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) enddo ; enddo endif @@ -965,28 +966,32 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif do j=js,je ; do i=is,ie ; if (ISS%area_shelf_h(i,j) > 0.0) then - frac_area = fluxes%frac_shelf_h(i,j) !### Should this be 1-frac_shelf_h? - if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 - if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = 0.0 - if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = 0.0 - if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir(i,j) = 0.0 - if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif(i,j) = 0.0 - if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 - if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 - if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 + ! Replace fluxes intercepted by the ice shelf with fluxes from the ice shelf + frac_shelf = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) + frac_open = max(0.0, 1.0 - frac_shelf) + + if (associated(fluxes%sw)) fluxes%sw(i,j) = frac_open * fluxes%sw(i,j) + if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = frac_open * fluxes%sw_vis_dir(i,j) + if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = frac_open * fluxes%sw_vis_dif(i,j) + if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir(i,j) = frac_open * fluxes%sw_nir_dir(i,j) + if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif(i,j) = frac_open * fluxes%sw_nir_dif(i,j) + if (associated(fluxes%lw)) fluxes%lw(i,j) = frac_open * fluxes%lw(i,j) + if (associated(fluxes%latent)) fluxes%latent(i,j) = frac_open * fluxes%latent(i,j) + if (associated(fluxes%evap)) fluxes%evap(i,j) = frac_open * fluxes%evap(i,j) if (associated(fluxes%lprec)) then if (ISS%water_flux(i,j) > 0.0) then - fluxes%lprec(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%lprec(i,j) = frac_shelf*ISS%water_flux(i,j)*CS%flux_factor + frac_open * fluxes%lprec(i,j) else - fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%lprec(i,j) = frac_open * fluxes%lprec(i,j) + fluxes%evap(i,j) = fluxes%evap(i,j) + frac_shelf*ISS%water_flux(i,j)*CS%flux_factor endif endif if (associated(fluxes%sens)) & - fluxes%sens(i,j) = frac_area*ISS%tflux_ocn(i,j)*CS%flux_factor + fluxes%sens(i,j) = frac_shelf*ISS%tflux_ocn(i,j)*CS%flux_factor + frac_open * fluxes%sens(i,j) + ! The salt flux should be mostly from sea ice, so perhaps none should be intercepted and this should be changed. if (associated(fluxes%salt_flux)) & - fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor + fluxes%salt_flux(i,j) = frac_shelf * ISS%salt_flux(i,j)*CS%flux_factor + frac_open * fluxes%salt_flux(i,j) endif ; enddo ; enddo if (CS%debug) then @@ -1008,16 +1013,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 - do j=js,je ; do i=is,ie - - !### These hard-coded limits need to be corrected. They are inappropriate here. - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - in_sponge(i,j) = 1.0 - else - in_sponge(i,j) = 0.0 - endif - enddo ; enddo - ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%override_shelf_movement .and. CS%mass_from_file) then dTime = real_to_time(CS%time_step) @@ -1025,18 +1020,24 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! Compute changes in mass after at least one full time step if (CS%Time > dTime) then Time0 = CS%Time - dTime - last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) + do j=js,je ; do i=is,ie + last_hmask(i,j) = ISS%hmask(i,j) ; last_area_shelf_h(i,j) = ISS%area_shelf_h(i,j) + enddo ; enddo call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) + do j=js,je ; do i=is,ie ! This should only be done if time_interp_external did an update. - last_mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(:,:) ! Rescale after time_interp - last_h_shelf(:,:) = last_mass_shelf(:,:) / CS%density_ice + last_mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(i,j) ! Rescale after time_interp + last_h_shelf(i,j) = last_mass_shelf(i,j) / CS%density_ice + enddo ; enddo ! apply calving if (CS%min_thickness_simple_calve > 0.0) then call ice_shelf_min_thickness_calve(G, last_h_shelf, last_area_shelf_h, last_hmask, & - CS%min_thickness_simple_calve) + CS%min_thickness_simple_calve, halo=0) ! convert to mass again - last_mass_shelf(:,:) = last_h_shelf(:,:) * CS%density_ice + do j=js,je ; do i=is,ie + last_mass_shelf(i,j) = last_h_shelf(i,j) * CS%density_ice + enddo ; enddo endif ! get total ice shelf mass at (Time-dt) and (Time), in kg @@ -1059,6 +1060,15 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif ! average total melt flux over sponge area + do j=js,je ; do i=is,ie + !### These hard-coded limits need to be corrected. They are inappropriate here. + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + in_sponge(i,j) = 1.0 + else + in_sponge(i,j) = 0.0 + endif + enddo ; enddo + sponge_area = global_area_integral(in_sponge, G) if (sponge_area > 0.0) then mean_melt_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & @@ -1754,7 +1764,7 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) if (CS%min_thickness_simple_calve > 0.0) then call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & - CS%min_thickness_simple_calve) + CS%min_thickness_simple_calve, halo=0) endif call pass_var(ISS%area_shelf_h, G%domain) From 684681b2b34403b7b293767beba7504ab7184ffe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 14:58:18 -0400 Subject: [PATCH 134/137] +Ice shelf code cleanup Added a new run-time parameter to specify how much water has to be under an ice shelf for it to float; this is only logged when the CONST_SEA_LEVEL option is true. The description of another parameter is corrected, which changes the MOM_parameter_doc files with ice shelf thermodynamics. In addition, merged the mass_shelf into the same loop as h_shelf in change_thickness_using_melt and reduced the loop extents for setting forces%p_surf. Use column masses instead of thicknesses for thresholds in MOM_ice_shelf. Also combined CS%Rho0 and CS%density_ocean_avg as CS%Rho_ocn in ice_shelf_CS. All answers are bitwise identical, but there are changes in output files in some cases. --- src/ice_shelf/MOM_ice_shelf.F90 | 73 ++++++++++++++++----------------- 1 file changed, 35 insertions(+), 38 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index ea9162afc5..cd9903bc82 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -94,7 +94,7 @@ module MOM_ice_shelf real :: cdrag !< drag coefficient under ice shelves [nondim]. real :: g_Earth !< The gravitational acceleration [Z T-2 ~> m s-2] real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. - real :: Rho0 !< A reference ocean density [R ~> kg m-3]. + real :: Rho_ocn !< A reference ocean density [R ~> kg m-3]. real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the !< 2-equation formulation [Z T-1 ~> m s-1]. @@ -109,7 +109,8 @@ module MOM_ice_shelf real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. - real :: col_thick_melt_threshold !< if the mixed layer is below this threshold, melt rate + real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting + !! does not occur [kg m-2] logical :: mass_from_file !< Read the ice shelf mass from a file every dt !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! @@ -127,10 +128,6 @@ module MOM_ice_shelf !!determined by ocean column thickness means update_OD_ffrac !! will be called (note: GL_regularize and GL_couple !! should be exclusive) - real :: density_ocean_avg !< this does not affect ocean circulation OR thermodynamics - !! it is to estimate the gravitational driving force at the - !! shelf front (until we think of a better way to do it, - !! but any difference will be negligible) logical :: calve_to_mask !< If true, calve any ice that passes outside of a masked area real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: T0 !< temperature at ocean surface in the restoring region [degC] @@ -154,6 +151,9 @@ module MOM_ice_shelf logical :: const_gamma !< If true, gamma_T is specified by the user. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. + real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice + !! shelf is considered to float when constant_sea_level + !! is used [kg m-2] real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] @@ -270,7 +270,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: dS_min, dS_max ! Variables used in iterating for wB_flux. real :: wB_flux_new, dDwB_dwB_in - real :: I_Gam_T, I_Gam_S, iDens + real :: I_Gam_T, I_Gam_S real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] real :: Isqrt2 logical :: Sb_min_set, Sb_max_set @@ -296,15 +296,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK - RhoCp = CS%Rho0 * CS%Cp + RhoCp = CS%Rho_ocn * CS%Cp Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component Gam_mol_t = 12.5 * (PR**c2_3) - 6 Gam_mol_s = 12.5 * (SC**c2_3) - 6 - iDens = 1.0/CS%density_ocean_avg - ! GMM, zero some fields of the ice shelf structure (ice_shelf_CS) ! these fields are already set to zero during initialization ! However, they seem to be changed somewhere and, for diagnostic @@ -350,7 +348,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! but it won't make a difference otherwise. fluxes%ustar_shelf(i,j)= 0.0 - if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then @@ -370,7 +368,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then ! ! These arrays are supposed to be stress components at C-grid points, which is ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho0*Isqrt2 + ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho_ocn*Isqrt2 ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) ! endif @@ -537,7 +535,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) exit ! no need to do interaction, so exit loop else - mass_exch = exch_vel_s(i,j) * CS%Rho0 + mass_exch = exch_vel_s(i,j) * CS%Rho_ocn Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * ISS%water_flux(i,j)) / & (mass_exch + ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) @@ -595,17 +593,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie - if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then - ! Set melt to zero above a cutoff pressure (CS%Rho0*CS%cutoff_depth*CS%g_Earth). + ! Set melt to zero above a cutoff pressure (CS%Rho_ocn*CS%cutoff_depth*CS%g_Earth). ! This is needed for the ISOMIP test case. - if (ISS%mass_shelf(i,j) < CS%Rho0*CS%cutoff_depth) then + if (ISS%mass_shelf(i,j) < CS%Rho_ocn*CS%cutoff_depth) then ISS%water_flux(i,j) = 0.0 fluxes%iceshelf_melt(i,j) = 0.0 endif ! Compute haline driving, which is one of the diags. used in ISOMIP - haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho0 * exch_vel_s(i,j)) + haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho_ocn * exch_vel_s(i,j)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! !1)Check if haline_driving computed above is consistent with @@ -739,20 +737,13 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice endif enddo ; enddo call pass_var(ISS%area_shelf_h, G%domain) call pass_var(ISS%h_shelf, G%domain) call pass_var(ISS%hmask, G%domain) - - !### combine this with the loops above. - do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice - endif - enddo ; enddo - call pass_var(ISS%mass_shelf, G%domain) end subroutine change_thickness_using_melt @@ -801,8 +792,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) endif - !### Consider working over a smaller array range. - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) if (associated(forces%p_surf)) then @@ -935,7 +925,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) ! GMM: melting is computed using ustar_shelf (and not ustar), which has already ! been passed, I so believe we do not need to update fluxes%ustar. -! Irho0 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / CS%Rho0 +! Irho0 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / CS%Rho_ocn ! do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. ! taux2 = 0.0 ; tauy2 = 0.0 @@ -969,7 +959,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! Replace fluxes intercepted by the ice shelf with fluxes from the ice shelf frac_shelf = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) frac_open = max(0.0, 1.0 - frac_shelf) - + if (associated(fluxes%sw)) fluxes%sw(i,j) = frac_open * fluxes%sw(i,j) if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = frac_open * fluxes%sw_vis_dir(i,j) if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = frac_open * fluxes%sw_vis_dif(i,j) @@ -1042,8 +1032,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! get total ice shelf mass at (Time-dt) and (Time), in kg do j=js,je ; do i=is,ie - ! just floating shelf (0.1 is a threshold for min ocean thickness) - if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & + ! Just consider the change in the mass of the floating shelf. + if ((state%ocean_mass(i,j) > CS%min_ocean_mass_float) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) else @@ -1127,6 +1117,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in ! a restart file to the internal representation in this run. real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. + real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered + ! to be floating when CONST_SEA_LEVEL = True [m]. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1139,6 +1131,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl logical :: read_TideAmp, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file real :: utide ! A tidal velocity [L T-1 ~> m s-1] + real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting + ! does not occur [m] if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") @@ -1246,6 +1240,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "ISOMIP+ experiments (Ocean3 and Ocean4). "//& "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) + call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & + "The minimum ocean thickness above which the ice shelf is considered to be "//& + "floating when CONST_SEA_LEVEL = True.", & + default=0.1, units="m", do_not_log=.not.CS%constant_sea_level) call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & "Surface salinity in the restoring region.", & @@ -1303,15 +1301,16 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The heat capacity of sea water, approximated as a constant. "//& "The default value is from the TEOS-10 definition of conservative temperature.", & units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + call get_param(param_file, mdl, "RHO_0", CS%Rho_ocn, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) !### MAKE THIS A SEPARATE PARAMETER. + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) + if (CS%constant_sea_level) CS%min_ocean_mass_float = dz_ocean_min_float*CS%Rho_ocn call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & "Non-dimensional factor applied to shelf thermodynamic "//& @@ -1334,17 +1333,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & "The molecular diffusivity of heat in sea water at the "//& "freezing point.", units="m2 s-1", default=1.41e-7, scale=US%m2_s_to_Z2_T) - call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & - "avg ocean density used in floatation cond", & - units="kg m-3", default=1035.) call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& "The default value is given by DT.", units="s", default=0.0) - call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", CS%col_thick_melt_threshold, & - "The minimum ML thickness where melting is allowed.", units="m", & + call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & + "The minimum ocean column thickness where melting is allowed.", units="m", & default=0.0) + CS%col_mass_melt_threshold = CS%Rho_ocn * col_thick_melt_thresh call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & "If true, read a file (given by TIDEAMP_FILE) containing "//& From 7cdffb103b4344899025498569f5b5e0ac23efe1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 18:12:25 -0400 Subject: [PATCH 135/137] (*)Use state%taux_shelf to set state%ustar_shelf If possible, use state%taux_shelf and %tauy_shelf to set state%ustar_shelf, or if these are not available use the (now appropriately staggered) state%u and state%v to set ustar%shelf. In addition, ustar%shelf is set in all cases with a thermodynamically interactive ice shelf, and not just those that use the 3-equation expressions for the skin salinity. In addition, when CONST_SEA_LEVEL is true, the balancing flux occurs over all open ocean area, although the previous mode of using a hard-coded region is still there in commented out code. These code changes alter answers in all cases with a thermodynamically interactive ice shelf, but the solutions in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 147 +++++++++++++++----------------- 1 file changed, 68 insertions(+), 79 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index cd9903bc82..733245b1ce 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -110,7 +110,7 @@ module MOM_ice_shelf real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting - !! does not occur [kg m-2] + !! does not occur [R Z ~> kg m-2] logical :: mass_from_file !< Read the ice shelf mass from a file every dt !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! @@ -153,7 +153,7 @@ module MOM_ice_shelf !! fluxes. It will avoid large increase in sea level. real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice !! shelf is considered to float when constant_sea_level - !! is used [kg m-2] + !! is used [R Z ~> kg m-2] real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] @@ -272,7 +272,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: wB_flux_new, dDwB_dwB_in real :: I_Gam_T, I_Gam_S real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] - real :: Isqrt2 + real :: taux2, tauy2 ! The squared surface stresses [Pa]. + real :: u2_av, v2_av ! The ice-area weighted average squared ocean velocities [L2 T-2 ~> m2 s-2] + real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u- + real :: asv1, asv2 ! and v-points [L2 ~> m2]. + real :: I_au, I_av ! The Adcroft reciprocals of the ice shelf areas at adjacent points [L-2 ~> m-2] + real :: Irho0 ! The inverse of the mean density times unit conversion factors that + ! arise because state uses MKS units [L2 m s2 kg-1 T-2 ~> m3 kg-1]. logical :: Sb_min_set, Sb_max_set logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true, the grouding line position is determined based on @@ -297,7 +303,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK RhoCp = CS%Rho_ocn * CS%Cp - Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component Gam_mol_t = 12.5 * (PR**c2_3) - 6 @@ -332,6 +337,37 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call hchksum(state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) endif + ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. + if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then + call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) + endif + Irho0 = US%m_s_to_L_T**2*US%kg_m3_to_R / CS%Rho_ocn + do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then + taux2 = 0.0 ; tauy2 = 0.0 ; u2_av = 0.0 ; v2_av = 0.0 + asu1 = (ISS%area_shelf_h(i-1,j) + ISS%area_shelf_h(i,j)) + asu2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) + asv1 = (ISS%area_shelf_h(i,j-1) + ISS%area_shelf_h(i,j)) + asv2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) + I_au = 0.0 ; if (asu1 + asu2 > 0.0) I_au = 1.0 / (asu1 + asu2) + I_av = 0.0 ; if (asv1 + asv2 > 0.0) I_av = 1.0 / (asv1 + asv2) + if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then + taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + asu2 * state%taux_shelf(I,j)**2 ) * I_au + tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + asv2 * state%tauy_shelf(i,J)**2 ) * I_av + endif + u2_av = US%m_s_to_L_T**2*(asu1 * state%u(I-1,j)**2 + asu2 * state%u(I,j)**2) * I_au + v2_av = US%m_s_to_L_T**2*(asv1 * state%v(i,J-1)**2 + asu2 * state%v(i,J)**2) * I_av + + if (taux2 + tauy2 > 0.0) then + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & + sqrt(Irho0 * sqrt(taux2 + tauy2) + CS%cdrag*CS%utide(i,j)**2)) + else ! Take care of the cases when taux_shelf is not set or not allocated. + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & + sqrt(CS%cdrag*((u2_av + v2_av) + CS%utide(i,j)**2))) + endif + else ! There is no shelf here. + fluxes%ustar_shelf(i,j) = 0.0 + endif ; enddo ; enddo + do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. @@ -344,11 +380,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) dR0_dT, dR0_dS, is, ie-is+1, CS%eqn_of_state) do i=is,ie - ! set ustar_shelf to zero. This is necessary if shelf_mass_is_dynamic - ! but it won't make a difference otherwise. - fluxes%ustar_shelf(i,j)= 0.0 - - if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then @@ -356,22 +388,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! salinity just below the ice-shelf as the variable that is being ! iterated for. - ! ### SHOULD USTAR_SHELF BE SET YET, or should it be set from taux_shelf & tauy_shelf? - ! I think that if taux_shelf and tauy_shelf have been calculated by the - ! ocean stress calculation, they should be used here or later to set ustar_shelf. - RWH - fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & - sqrt(CS%cdrag*(US%m_s_to_L_T**2*(state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**2))) - ustar_h = fluxes%ustar_shelf(i,j) - ! I think that the following can be deleted without causing any problems. - ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - ! ! These arrays are supposed to be stress components at C-grid points, which is - ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho_ocn*Isqrt2 - ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) - ! endif - ! Estimate the neutral ocean boundary layer thickness as the minimum of the ! reported ocean mixed layer thickness and the neutral Ekman depth. absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & @@ -593,7 +611,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie - if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then ! Set melt to zero above a cutoff pressure (CS%Rho_ocn*CS%cutoff_depth*CS%g_Earth). @@ -869,20 +887,16 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. ! local variables - real :: Irho0 !< The inverse of the mean density times unit conversion factors that - !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] - real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. - real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- - real :: asv1, asv2 !< and v-points [L2 ~> m2]. - real :: mean_melt_flux !< Spatial mean melt flux [R Z T-1 ~> kg m-2 s-1] - real :: sponge_area !< total area of sponge region [m2] + real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] + real :: balancing_area !< total area where the balancing flux is applied [m2] type(time_type) :: dTime !< The time step as a time_type type(time_type) :: Time0 !< The previous time (Time-dt) - real, dimension(SZDI_(G),SZDJ_(G)) :: in_sponge !< 1 where the property damping occurs, 0 otherwise [nondim] + real, dimension(SZDI_(G),SZDJ_(G)) :: bal_frac !< Fraction of the cel1 where the mass flux + !! balancing the net melt flux occurs, 0 to 1 [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] real, dimension(SZDI_(G),SZDJ_(G)) :: delta_float_mass !< The change in the floating mass between @@ -921,29 +935,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif endif - if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) - ! GMM: melting is computed using ustar_shelf (and not ustar), which has already - ! been passed, I so believe we do not need to update fluxes%ustar. -! Irho0 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / CS%Rho_ocn -! do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then - ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. - ! taux2 = 0.0 ; tauy2 = 0.0 - ! asu1 = (ISS%area_shelf_h(i-1,j) + ISS%area_shelf_h(i,j)) - ! asu2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) - ! asv1 = (ISS%area_shelf_h(i,j-1) + ISS%area_shelf_h(i,j)) - ! asv2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) - ! if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & - ! taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + & - ! asu2 * state%taux_shelf(I,j)**2 ) / (asu1 + asu2) - ! if ((asv1 + asv2 > 0.0) .and. associated(state%tauy_shelf)) & - ! tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + & - ! asv2 * state%tauy_shelf(i,J)**2 ) / (asv1 + asv2) - - ! fluxes%ustar(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) -! endif ; enddo ; enddo - endif - if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then do j=jsd,jed ; do i=isd,ied if (G%areaT(i,j) > 0.0) & @@ -990,15 +981,12 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) endif - ! keep sea level constant by removing mass in the sponge - ! region (via virtual precip, vprec). Apply additional - ! salt/heat fluxes so that the resultant surface buoyancy - ! forcing is ~ 0. + ! Keep sea level constant by removing mass via a balancing flux that might be applied + ! in the open ocean or the sponge region (via virtual precip, vprec). Apply additional + ! salt/heat fluxes so that the resultant surface buoyancy forcing is ~ 0. ! This is needed for some of the ISOMIP+ experiments. if (CS%constant_sea_level) then - !### This code has problems with hard coded constants that need to be refactored. -RWH - if (.not. associated(fluxes%salt_flux)) allocate(fluxes%salt_flux(ie,je)) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 @@ -1033,7 +1021,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! get total ice shelf mass at (Time-dt) and (Time), in kg do j=js,je ; do i=is,ie ! Just consider the change in the mass of the floating shelf. - if ((state%ocean_mass(i,j) > CS%min_ocean_mass_float) .and. & + if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%min_ocean_mass_float) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) else @@ -1051,35 +1039,36 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! average total melt flux over sponge area do j=js,je ; do i=is,ie - !### These hard-coded limits need to be corrected. They are inappropriate here. - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - in_sponge(i,j) = 1.0 + if ((G%mask2dT(i,j) > 0.0) .AND. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then + ! Uncomment this for some ISOMIP cases: + ! .AND. (G%geoLonT(i,j) >= 790.0) .AND. (G%geoLonT(i,j) <= 800.0)) then + bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) else - in_sponge(i,j) = 0.0 + bal_frac(i,j) = 0.0 endif enddo ; enddo - sponge_area = global_area_integral(in_sponge, G) - if (sponge_area > 0.0) then - mean_melt_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & + balancing_area = global_area_integral(bal_frac, G) + if (balancing_area > 0.0) then + balancing_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & area=ISS%area_shelf_h) + & - delta_mass_shelf ) / sponge_area + delta_mass_shelf ) / balancing_area else - mean_melt_flux = 0.0 + balancing_flux = 0.0 endif ! apply fluxes do j=js,je ; do i=is,ie - if (in_sponge(i,j) > 0.0) then + if (bal_frac(i,j) > 0.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - fluxes%vprec(i,j) = -mean_melt_flux + fluxes%vprec(i,j) = -balancing_flux fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif enddo ; enddo if (CS%debug) then - write(mesg,*) 'Mean melt flux (kg/(m^2 s)), dt = ', mean_melt_flux*US%RZ_T_to_kg_m2s, CS%time_step + write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, CS%time_step call MOM_mesg(mesg) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif @@ -1118,7 +1107,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! a restart file to the internal representation in this run. real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered - ! to be floating when CONST_SEA_LEVEL = True [m]. + ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1243,7 +1232,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & "The minimum ocean thickness above which the ice shelf is considered to be "//& "floating when CONST_SEA_LEVEL = True.", & - default=0.1, units="m", do_not_log=.not.CS%constant_sea_level) + default=0.1, units="m", scale=US%m_to_Z, do_not_log=.not.CS%constant_sea_level) call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & "Surface salinity in the restoring region.", & @@ -1339,8 +1328,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The default value is given by DT.", units="s", default=0.0) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & - "The minimum ocean column thickness where melting is allowed.", units="m", & - default=0.0) + "The minimum ocean column thickness where melting is allowed.", & + units="m", scale=US%m_to_Z, default=0.0) CS%col_mass_melt_threshold = CS%Rho_ocn * col_thick_melt_thresh call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & @@ -1389,7 +1378,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & - "The minimum value of ustar under ice sheves.", & + "The minimum value of ustar under ice shelves.", & units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) call get_param(param_file, mdl, "CDRAG_SHELF", cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& From 43ebd34bb1f79042f787a06b13ade68f4f375217 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 2 Apr 2020 14:55:00 -0400 Subject: [PATCH 136/137] Removed spaces from a blank line --- src/framework/MOM_spatial_means.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index d4b687b0a5..2423a19433 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -56,7 +56,7 @@ function global_area_integral(var, G, scale, area) real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including !! any required masking [L2 ~> m2]. real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. - + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. From f75edd93a554d94770793c482ee4796860d37b5b Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Apr 2020 21:25:05 -0800 Subject: [PATCH 137/137] Added a ramp option for SSH OBCs. --- src/core/MOM_dynamics_split_RK2.F90 | 11 ++++- src/core/MOM_open_boundary.F90 | 77 +++++++++++++++++++++++++++-- 2 files changed, 82 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index db9d1ada73..8c0decd8c1 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -49,7 +49,7 @@ module MOM_dynamics_split_RK2 use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds use MOM_open_boundary, only : open_boundary_zero_normal_flow -use MOM_open_boundary, only : open_boundary_test_extern_h +use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS @@ -364,6 +364,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (associated(CS%OBC)) then if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) + ! Update OBC ramp value as function of time + call update_OBC_ramp(Time_local, CS%OBC) + do k=1,nz ; do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB u_old_rad_OBC(I,j,k) = u_av(I,j,k) enddo ; enddo ; enddo @@ -1120,7 +1123,11 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param activate=is_new_run(restart_CS) ) if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp - if (associated(OBC)) CS%OBC => OBC + if (associated(OBC)) then + CS%OBC => OBC + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, & + activate=is_new_run(restart_CS) ) + endif if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp eta_rest_name = "sfc" ; if (.not.GV%Boussinesq) eta_rest_name = "p_bot" diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 927548665e..3b1559ab81 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,6 +9,7 @@ module MOM_open_boundary use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : NOTE use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type, hor_index_type use MOM_dyn_horgrid, only : dyn_horgrid_type @@ -18,6 +19,7 @@ module MOM_open_boundary use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces +use MOM_time_manager, only : time_type, time_type_to_real, operator(-) use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init @@ -54,6 +56,7 @@ module MOM_open_boundary public fill_temp_salt_segments public open_boundary_register_restarts public update_segment_tracer_reservoirs +public update_OBC_ramp integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary @@ -280,6 +283,14 @@ module MOM_open_boundary !! the independence of the OBCs to this external data [H ~> m or kg m-2]. real :: silly_u !< A silly value of velocity outside of the domain that can be used to test !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. + logical :: ramp = .false. !< If True, ramp from zero to the external values + !! for SSH. + logical :: ramping_is_activated = .false. !< True if the ramping has been initialized + real :: ramp_timescale !< If ramp is True, use this timescale for ramping. + real :: trunc_ramp_time !< If ramp is True, time after which ramp is done. + real :: ramp_value !< If ramp is True, where we are on the ramp from + !! zero to one. + type(time_type) :: ramp_start_time !< Time when model was started. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -402,6 +413,14 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & "If true, set the areas outside open boundaries to be land.", & default=.false.) + call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, & + "If true, ramps from zero to the external values over time, with"//& + "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far", & + default=.false.) + call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, & + "If RAMP_OBCS is true, this sets the ramping timescale.", & + units="days", default=1.0, scale=86400.0*US%s_to_T) + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) if (debug_OBC .or. debug) & @@ -3873,11 +3892,19 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif if (trim(segment%field(m)%name) == 'SSH') then - do j=js_obc2,je_obc - do i=is_obc2,ie_obc - segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + if (OBC%ramp) then + do j=js_obc2,je_obc + do i=is_obc2,ie_obc + segment%eta(i,j) = OBC%ramp_value * segment%field(m)%buffer_dst(i,j,1) + enddo enddo - enddo + else + do j=js_obc2,je_obc + do i=is_obc2,ie_obc + segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + enddo + enddo + endif endif if (trim(segment%field(m)%name) == 'TEMP') then @@ -3920,6 +3947,48 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) end subroutine update_OBC_segment_data +!> Update the OBC ramp value as a function of time. +!! If called with the optional argument activate=.true., record the +!! value of Time as the beginning of the ramp period. +subroutine update_OBC_ramp(Time, OBC, activate) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, optional, intent(in) :: activate !< Specifiy whether to record the value of + !! Time as the beginning of the ramp period + + ! Local variables + real :: deltaTime, wghtA + character(len=12) :: msg + + if (.not. OBC%ramp) return ! This indicates the ramping is turned off + + ! We use the optional argument to indicate this Time should be recorded as the + ! beginning of the ramp-up period. + if (present(activate)) then + if (activate) then + OBC%ramp_start_time = Time ! Record the current time + OBC%ramping_is_activated = .true. + OBC%trunc_ramp_time = OBC%ramp_timescale ! times 3.0 for tanh + endif + endif + if (.not.OBC%ramping_is_activated) return + deltaTime = max( 0., time_type_to_real( Time - OBC%ramp_start_time ) ) + if (deltaTime >= OBC%trunc_ramp_time) then + OBC%ramp_value = 1.0 + OBC%ramp = .false. ! This turns off ramping after this call + else + wghtA = min( 1., deltaTime / OBC%ramp_timescale ) ! Linear profile in time + !wghtA = wghtA*wghtA ! Convert linear profile to parabolic profile in time + !wghtA = wghtA*wghtA*(3. - 2.*wghtA) ! Convert linear profile to cosine profile + !wghtA = 1. - ( (1. - wghtA)**2 ) ! Convert linear profile to inverted parabolic profile + !wghtA = tanh(wghtA) ! Convert linear profile to tanh + OBC%ramp_value = wghtA + endif + write(msg(1:12),'(es12.3)') OBC%ramp_value + call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC"// & + " ramp to "//trim(msg)) +end subroutine update_OBC_ramp + !> register open boundary objects for boundary updates. subroutine register_OBC(name, param_file, Reg) character(len=32), intent(in) :: name !< OBC name used for error messages