From c074a9cf17728a9e2ef81f847c0aa11ab4459414 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 16 Oct 2017 16:09:02 -0400 Subject: [PATCH 001/170] Neutral diffusion: Filter out unstable part of the water column For the unstably stratified part of the water column, neutral surfaces would intersect. To solve this, we choose to remove those parts of the water column from consideration. Need to test that this code is doing what we want --- src/tracer/MOM_neutral_diffusion.F90 | 717 ++++++++--------------- src/tracer/MOM_neutral_diffusion_aux.F90 | 489 ++++++++++++++++ 2 files changed, 745 insertions(+), 461 deletions(-) create mode 100644 src/tracer/MOM_neutral_diffusion_aux.F90 diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 05b6164108..491e0454b7 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -3,25 +3,27 @@ module MOM_neutral_diffusion ! 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_EOS, only : EOS_type, EOS_manual_init, calculate_compress, calculate_density_derivs -use MOM_EOS, only : calculate_density_second_derivs -use MOM_EOS, only : extract_member_EOS, EOS_LINEAR, EOS_TEOS10, EOS_WRIGHT -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 -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 +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_EOS, only : EOS_type, EOS_manual_init, calculate_compress, calculate_density_derivs +use MOM_EOS, only : calculate_density_second_derivs +use MOM_EOS, only : extract_member_EOS, EOS_LINEAR, EOS_TEOS10, EOS_WRIGHT +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_neutral_diffusion_aux, only : mark_unstable_cells, mark_unstable_cells_i, refine_nondim_position +use MOM_neutral_diffusion_aux, only : calc_delta_rho, check_neutral_positions +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 +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 @@ -70,6 +72,9 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: S_i ! Top edge reconstruction of salinity (ppt) real, allocatable, dimension(:,:,:,:) :: dRdT_i ! dRho/dT (kg/m3/degC) at top edge real, allocatable, dimension(:,:,:,:) :: dRdS_i ! dRho/dS (kg/m3/ppt) at top edge + integer, allocatable, dimension(:,:) :: ns ! Number of interfacs in a column + + logical, allocatable, dimension(:,:,:) :: stable_cell ! True if the cell is stably stratified wrt to the next cell type(diag_ctrl), pointer :: diag ! structure to regulate output integer, allocatable, dimension(:) :: id_neutral_diff_tracer_conc_tend ! tracer concentration tendency @@ -188,11 +193,13 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) allocate(CS%dRdS_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%dRdS_i(:,:,:,:) = 0. allocate(CS%ppoly_coeffs_T(SZI_(G),SZJ_(G),SZK_(G),CS%ppoly_deg+1)) ; CS%ppoly_coeffs_T(:,:,:,:) = 0. allocate(CS%ppoly_coeffs_S(SZI_(G),SZJ_(G),SZK_(G),CS%ppoly_deg+1)) ; CS%ppoly_coeffs_S(:,:,:,:) = 0. + allocate(CS%ns(SZI_(G),SZJ_(G))) ; CS%ns(:,:) = 0. endif ! T-points allocate(CS%Tint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Tint(:,:,:) = 0. allocate(CS%Sint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Sint(:,:,:) = 0. allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Pint(:,:,:) = 0. + allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(G))) ; CS%stable_cell(:,:,:) = .true. ! U-points allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. @@ -357,13 +364,18 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) ! Local variables integer :: i, j, k + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: dRdT_l !< Potential temperature (degC) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: dRdS_l !< Salinity (ppt) ! Variables used for reconstructions real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta + real :: dRho, P_lay ! If doing along isopycnal diffusion (as opposed to neutral diffusion, set the reference pressure) - if (CS%ref_pres>=0.) ref_pres(:) = CS%ref_pres + if (CS%ref_pres>=0.) then + ref_pres(:) = CS%ref_pres + endif if (CS%continuous_reconstruction) then CS%dRdT(:,:,:) = 0. @@ -375,12 +387,24 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) CS%dRdS_i(:,:,:,:) = 0. endif - ! Calculate pressure at interfaces + ! Calculate pressure at interfaces and layer averaged alpha/beta CS%Pint(:,:,1) = 0. do k=1,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 - CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*GV%H_to_Pa + CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*GV%H_to_Pa + if (CS%ref_pres<=0.) then + P_lay = 0.5*(CS%Pint(i,j,k+1) + CS%Pint(i,j,k)) + call calculate_density_derivs(T(i,j,k), S(i,j,k), P_lay, dRdT_l(i,j,k), dRdS_l(i,j,k), EOS) + else + call calculate_density_derivs(T(i,j,k), S(i,j,k), CS%ref_pres, dRdT_l(i,j,k), dRdS_l(i,j,k), EOS) + endif enddo ; enddo ; enddo + 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( G%ke, dRdT_l(i,j,:), dRdS_l(i,j,:), T(i,j,:), S(i,j,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) + enddo ; enddo + endif + do j = G%jsc-1, G%jec+1 ! Interpolate state to interface do i = G%isc-1, G%iec+1 @@ -407,13 +431,17 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, EOS) - if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k+1) + if (CS%ref_pres<0) then + ref_pres(:) = CS%Pint(:,j,k+1) + endif call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, EOS) enddo + call mark_unstable_cells_i( G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) endif enddo + CS%uhEff(:,:,:) = 0. CS%vhEff(:,:,:) = 0. CS%uPoL(:,:,:) = 0. @@ -434,11 +462,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) 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,:) ) else - call find_neutral_surface_positions_discontinuous(G%ke, CS%ppoly_deg, & - CS%Pint(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), & - CS%Pint(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%dRdT_i(i+1,j,:,:), CS%dRdS_i(i+1,j,:,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & - CS%refine_position, CS%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & + call find_neutral_surface_positions_discontinuous(G%ke, CS%ns(i,j)+ CS%ns(i+1,j), CS%ppoly_deg, & + CS%Pint(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & + CS%Pint(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), & + CS%dRdT_i(i+1,j,:,:), CS%dRdS_i(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%refine_position, CS%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & CS%ppoly_coeffs_T(i+1,j,:,:), CS%ppoly_coeffs_S(i+1,j,:,:), EOS, CS%max_iter, CS%tolerance, CS%ref_pres) endif endif @@ -453,12 +483,15 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) 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,:) ) else - call find_neutral_surface_positions_discontinuous(G%ke, CS%ppoly_deg, & - CS%Pint(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), & - CS%Pint(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%dRdT_i(i,j+1,:,:), CS%dRdS_i(i,j+1,:,:), & + call find_neutral_surface_positions_discontinuous(G%ke, CS%ns(i,j)+CS%ns(i,j+1), CS%ppoly_deg, & + CS%Pint(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & + CS%Pint(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), & + CS%dRdT_i(i,j+1,:,:), CS%dRdS_i(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%refine_position, CS%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & CS%ppoly_coeffs_T(i,j+1,:,:), CS%ppoly_coeffs_S(i,j+1,:,:), EOS, CS%max_iter, CS%tolerance, CS%ref_pres) + endif endif enddo ; enddo @@ -1047,21 +1080,24 @@ end subroutine find_neutral_surface_positions_continuous !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S -subroutine find_neutral_surface_positions_discontinuous(nk, deg, & - Pres_l, Tl, Sl, dRdT_l, dRdS_l, Pres_r, Tr, Sr, dRdT_r, dRdS_r, PoL, PoR, KoL, KoR, hEff, & - refine_pos_in, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r, EOS, max_iter, tolerance, ref_pres) +subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, & + Pres_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, PoL, PoR, KoL, KoR,& + hEff, refine_pos_in, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r, EOS, max_iter, tolerance, ref_pres) integer, intent(in) :: nk !< Number of levels + integer, intent(in) :: ns !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial used for reconstructions real, dimension(nk+1), intent(in) :: Pres_l !< Left-column interface pressure (Pa) real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature (degC) real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity (ppt) real, dimension(nk,2), intent(in) :: dRdT_l !< Left-column, top interface dRho/dT (kg/m3/degC) real, dimension(nk,2), intent(in) :: dRdS_l !< Left-column, top interface dRho/dS (kg/m3/ppt) + logical, dimension(nk), intent(in) :: stable_l !< Left-column, top interface dRho/dS (kg/m3/ppt) real, dimension(nk+1), intent(in) :: Pres_r !< Right-column interface pressure (Pa) real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature (degC) real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity (ppt) real, dimension(nk,2), intent(in) :: dRdT_r !< Right-column, top interface dRho/dT (kg/m3/degC) real, dimension(nk,2), intent(in) :: dRdS_r !< Right-column, top interface dRho/dS (kg/m3/ppt) + logical, dimension(nk), intent(in) :: stable_r !< Left-column, top interface dRho/dS (kg/m3/ppt) real, dimension(4*nk), intent(inout) :: PoL !< Fractional position of neutral surface within !! layer KoL of left column real, dimension(4*nk), intent(inout) :: PoR !< Fractional position of neutral surface within @@ -1080,7 +1116,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, real, optional, intent(in) :: ref_pres !< Reference pressure to use for deriviative calculation ! Local variables - integer :: ns ! Number of neutral surfaces integer :: k_surface ! Index of neutral surface integer :: kl_left, kl_right ! Index of layers on the left/right integer :: ki_left, ki_right ! Index of interfaces on the left/right @@ -1088,6 +1123,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, 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 :: refine_pos ! Use rootfinding to find the true neutral surface position + integer :: k, kl_left_0, kl_right_0 real :: dRho, dRhoTop, dRhoBot, dRhoTopm1, hL, hR integer :: lastK_left, lastK_right, maxK_left, maxK_right real :: lastP_left, lastP_right @@ -1095,7 +1131,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, logical, dimension(nk) :: top_connected_l, top_connected_r logical, dimension(nk) :: bot_connected_l, bot_connected_r - ns = 4*nk top_connected_l(:) = .false. ; top_connected_r(:) = .false. bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. maxK_left = -1 ; maxK_right = -1 @@ -1114,22 +1149,37 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, "coefficients not available for T and S") endif + do k = 1,nk + if (stable_l(k)) then + kl_left = k + kl_left_0 = k + exit + endif + enddo + do k = 1,nk + if (stable_r(k)) then + kl_right = k + kl_right_0 = k + exit + endif + enddo + ! Initialize variables for the search - kl_right = 1 ; ki_right = 1 ; lastK_right = 1 ; lastP_right = -1. - kl_left = 1 ; ki_left = 1 ; lastK_left = 1 ; lastP_left = -1. + ki_right = 1 ; lastK_right = 1 ; lastP_right = -1. + ki_left = 1 ; lastK_left = 1 ; lastP_left = -1. reached_bottom = .false. searching_left_column = .false. searching_right_column = .false. ! Loop over each neutral surface, working from top to bottom - neutral_surfaces: do k_surface = 1, 4*nk + neutral_surfaces: do k_surface = 1, ns ! Potential density difference, rho(kr) - rho(kl) dRho = 0.5 * & ( ( dRdT_r(kl_right,ki_right) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,ki_right) - Tl(kl_left,ki_left) ) & + ( dRdS_r(kl_right,ki_right) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,ki_right) - Sl(kl_left,ki_left) ) ) - if (debug_this_module) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho," kl_left=",kl_left, & - " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right + if (debug_this_module) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho," & + kl_left=",kl_left, " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right ! Which column has the lighter surface for the current indexes, kr and kl if (.not. reached_bottom) then if (dRho < 0.) then @@ -1139,7 +1189,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, searching_right_column = .true. searching_left_column = .false. else ! dRho == 0. - if ((kl_left + kl_left == 2) .and. (ki_left + ki_right == 2)) then ! Still at surface + if ( ( kl_left == kl_left_0) .and. ( kl_right == kl_right_0 ) .and. (ki_left + ki_right == 2) ) then ! Still at surface searching_left_column = .true. searching_right_column = .false. else ! Not the surface so we simply change direction @@ -1159,10 +1209,12 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, dRhoBot = 0.5 * & ( ( dRdT_l(kl_left,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left,2) - Tr(kl_right,ki_right) ) & + ( dRdS_l(kl_left,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left,2) - Sr(kl_right,ki_right) ) ) - if (kl_left>1) then ! Calculate the density difference at top of discontinuity - dRhoTopm1 = 0.5 * & - ( ( dRdT_l(kl_left-1,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left-1,2) - Tr(kl_right,ki_right) ) & - + ( dRdS_l(kl_left-1,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left-1,2) - Sr(kl_right,ki_right) ) ) + if (kl_left>kl_left_0) then + if (stable_l(kl_left-1) ) then ! Calculate the density difference at top of discontinuity + dRhoTopm1 = 0.5 * & + ( ( dRdT_l(kl_left-1,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left-1,2) - Tr(kl_right,ki_right) ) & + + ( dRdS_l(kl_left-1,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left-1,2) - Sr(kl_right,ki_right) ) ) + endif else dRhoTopm1 = dRhoTop endif @@ -1180,19 +1232,22 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, KoR(k_surface) = REAL(kl_right) ! Set position within the searched column - call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & - lastP_left, lastK_left, kl_left, ki_left, top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface)) + call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & + lastP_left, lastK_left, kl_left, kl_left_0, ki_left, top_connected_l, bot_connected_l, & + PoL(k_surface), KoL(k_surface)) if ( refine_pos .and. (PoL(k_surface) > 0.) .and. (PoL(k_surface) < 1.) ) then min_bound = 0. - if ( (k_surface > 1) .and. ( KoL(k_surface) == KoL(k_surface-1) ) ) min_bound = PoL(k_surface-1) + if (k_surface > 1) then + if ( KoL(k_surface) == KoL(k_surface-1) ) min_bound = PoL(k_surface-1) + endif PoL(k_surface) = refine_nondim_position(max_iter, tolerance, Tr(kl_right,ki_right), Sr(kl_right,ki_right), & dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), Pres_l(kl_left), Pres_l(kl_left+1), & - deg, ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), EOS, PoL(k_surface), dRhoTop, dRhoBot, min_bound, & + deg, ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), EOS, min_bound, dRhoTop, dRhoBot, min_bound, & ref_pres) endif if (PoL(k_surface) == 0.) top_connected_l(KoL(k_surface)) = .true. if (PoL(k_surface) == 1.) bot_connected_l(KoL(k_surface)) = .true. - call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) + call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, searching_right_column, searching_left_column) lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) elseif (searching_right_column) then @@ -1204,10 +1259,12 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, dRhoBot = 0.5 * & ( ( dRdT_r(kl_right,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,2) - Tl(kl_left,ki_left) ) & + ( dRdS_r(kl_right,2) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,2) - Sl(kl_left,ki_left) ) ) - if (kl_right>1) then - dRhoTopm1 = 0.5 * & - ( ( dRdT_r(kl_right-1,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right-1,2) - Tl(kl_left,ki_left) ) & - + ( dRdS_r(kl_right-1,2) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right-1,2) - Sl(kl_left,ki_left) ) ) + if (kl_right>kl_right_0) then + if(stable_r(kl_right-1)) then + dRhoTopm1 = 0.5 * & + ( ( dRdT_r(kl_right-1,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right-1,2) - Tl(kl_left,ki_left) ) & + + ( dRdS_r(kl_right-1,2) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right-1,2) - Sl(kl_left,ki_left) ) ) + endif else dRhoTopm1 = dRhoTop endif @@ -1225,24 +1282,30 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, ! Set position within the searched column call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), & - lastP_right, lastK_right, kl_right, ki_right, top_connected_r, bot_connected_r, PoR(k_surface), KoR(k_surface)) + lastP_right, lastK_right, kl_right, kl_right_0, ki_right, top_connected_r, bot_connected_r, & + PoR(k_surface), KoR(k_surface)) if ( refine_pos .and. (PoR(k_surface) > 0. .and. PoR(k_surface) < 1.) ) then min_bound = 0. - if ( (k_surface > 1) .and. ( KoR(k_surface) == KoR(k_surface-1) ) ) min_bound = PoR(k_surface-1) + if (k_surface > 1) then + if ( KoR(k_surface) == KoR(k_surface-1) ) min_bound = PoR(k_surface-1) + endif PoR(k_surface) = refine_nondim_position(max_iter, tolerance, Tl(kl_left,ki_left), Sl(kl_left,ki_left), & dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), Pres_r(kl_right), Pres_r(kl_right+1), & - deg, ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), EOS, PoR(k_surface), dRhoTop, dRhoBot, min_bound, & + deg, ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), EOS, min_bound, dRhoTop, dRhoBot, min_bound, & ref_pres) endif if (PoR(k_surface) == 0.) top_connected_r(KoR(k_surface)) = .true. if (PoR(k_surface) == 1.) bot_connected_r(KoR(k_surface)) = .true. - call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) + call increment_interface(nk, kl_left, ki_left, stable_l, reached_bottom, searching_left_column, searching_right_column) lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) else stop 'Else what?' endif - if (debug_this_module) write(*,'(A,I2,A,F6.2,A,I2,A,F6.2)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & + lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) + lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) + + if (debug_this_module) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & KoR(k_surface), " PoR:", PoR(k_surface) maxK_left= MAX(KoL(k_surface), maxK_left) maxK_right= MAX(KoR(k_surface), maxK_right) @@ -1254,46 +1317,70 @@ subroutine find_neutral_surface_positions_discontinuous(nk, deg, hR = absolute_position(nk,ns,Pres_r,KoR,PoR,k_surface) - absolute_position(nk,ns,Pres_r,KoR,PoR,k_surface-1) ! In the case of a layer being unstably stratified, may get a negative thickness. Set the previous position ! to the current location - if (hL < 0.) then - if ( (KoL(k_surface) 0.) then + if ( hL<0. .or. hR<0. ) then + hEff(k_surface-1) = 0. + call MOM_error(FATAL, "hL or hR is negative") + elseif ( hL + hR > 0.) then hEff(k_surface-1) = 2. * hL * hR / ( hL + hR ) ! Harmonic mean else hEff(k_surface-1) = 0. endif + if (hEff(k_surface-1)>0.) then + if ( (KoL(k_surface-1) /= KoL(k_surface)) .or. (KoR(k_surface-1) /= KoR(k_surface)) ) then + call MOM_error(FATAL,"Neutral surfaces span multiple layers") + endif + endif + endif enddo neutral_surfaces + ! Check to make sure that neutral surfaces are truly neutral + if (debug_this_module) then + do k_surface = 1,ns-1 + if (hEff(k_surface)>0.) then + kl_left = KoL(k_surface) + kl_right = KoR(k_surface) + if (refine_pos) then + if ( check_neutral_positions(deg, EOS, & + PoL(k_surface), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), (/Pres_l(kl_left),Pres_l(kl_left+1)/), & + PoR(k_surface), ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), (/Pres_r(kl_right),Pres_r(kl_right+1)/),& + tolerance, ref_pres) ) then + print *, "k_surface: ", k_surface + call MOM_error(WARNING,"Endpoints of neutral surfaces have different densities") + endif + endif + endif + enddo + endif end subroutine find_neutral_surface_positions_discontinuous !> Increments the interface which was just connected and also set flags if the bottom is reached -subroutine increment_interface(nk, kl, ki, reached_bottom, searching_this_column, searching_other_column) - integer, intent(in ) :: nk !< Number of vertical levels - integer, intent(inout) :: kl !< Current layer (potentially updated) - integer, intent(inout) :: ki !< Current interface - logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 - logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 - logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 +subroutine increment_interface(nk, kl, ki, stable, reached_bottom, searching_this_column, searching_other_column) + integer, intent(in ) :: nk !< Number of vertical levels + integer, intent(inout) :: kl !< Current layer (potentially updated) + integer, intent(inout) :: ki !< Current interface + logical, dimension(nk), intent(in ) :: stable !< True if the cell is stably stratified + logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 + logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 + logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 + integer :: k if (ki == 1) then ki = 2 - elseif ((ki == 2) .and. (kl < nk)) then + elseif ((ki == 2) .and. (kl < nk) ) then ki = 1 - kl = kl + 1 + do k = kl+1,nk + if (stable(kl)) then + kl = k + exit + endif + ! If we did not find another stable cell, then the current cell is essentially the bottom + ki = 2 + reached_bottom = .true. + searching_this_column = .true. + searching_other_column = .false. + enddo elseif ((kl == nk) .and. (ki==2)) then reached_bottom = .true. searching_this_column = .true. @@ -1306,7 +1393,7 @@ subroutine increment_interface(nk, kl, ki, reached_bottom, searching_this_column end subroutine increment_interface !> Searches the "other" (searched) column for the position of the neutral surface -subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, ki, & +subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, kl_0, ki, & top_connected, bot_connected, out_P, out_K) real, intent(in ) :: dRhoTopm1 !< Density difference across previous interface real, intent(in ) :: dRhoTop !< Density difference across top interface @@ -1316,6 +1403,7 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, real, intent(in ) :: lastP !< Last position connected in the searched column integer, intent(in ) :: lastK !< Last layer connected in the searched column integer, intent(in ) :: kl !< Layer in the searched column + integer, intent(in ) :: kl_0 !< Layer in the searched column integer, intent(in ) :: ki !< Interface of the searched column logical, dimension(:), intent(inout) :: top_connected !< True if the top interface was pointed to logical, dimension(:), intent(inout) :: bot_connected !< True if the top interface was pointed to @@ -1328,16 +1416,16 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, ! Bad values to make sure that the particular setup has been processed out_P = -1. ; out_K = -1 ! Check if everything in this layer is denser than neutral surface or if at the top of the water column - if ((kl==1 .and. ki==1)) then + if ((kl==kl_0 .and. ki==1)) then if (debug_this_module) write(*,*) "At surface" out_P = 0. ; out_K = kl search_layer = .false. ! Deal with the case where reconstruction is continuous - elseif ( kl>1 ) then + elseif ( kl>kl_0 .and. lastK 0.) ) then + elseif ( (dRhoTopm1 0.)) then out_P = 1. ; out_K = kl-1 search_layer = .false. endif @@ -1345,10 +1433,25 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, if (search_layer) then if (dRhoTop > 0.) then - out_P = 0. ; out_K = kl + if (debug_this_module) write(*,*) "dRhoTop > 0." + if (lastK < kl) then + out_P = 0. ; out_K = kl + elseif (lastK == kl) then + out_P = lastP ; out_K = lastK + endif elseif ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then - out_P = 0. ; out_K = kl + if (debug_this_module) write(*,*) "dRhoTop == 0. .and. not top_connected" +! if ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then + if (lastK < kl) then + out_P = 0. ; out_K = kl + elseif (lastK == kl) then + out_P = lastP ; out_K = lastK + endif elseif (dRhoTop >= dRhoBot) then + if (debug_this_module) write(*,*) "dRhoTop >= dRhoBot" + out_P = 1. ; out_K = kl + elseif ( (dRhoTop < 0.) .and. (dRhoBot < 0.) ) then + if (debug_this_module) write(*,*) "dRhoTop < 0. .and. dRhoBot < 0." out_P = 1. ; out_K = kl else if (debug_this_module) write(*,*) "Zero crossing point within layer" @@ -1362,7 +1465,7 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, endif ! Check to make sure that the layer index is always increasing if ( (out_K < lastK) .and. lastP==0. .and. out_P == 1. ) then - out_K = lastK ; out_P = 0. +! out_K = lastK ; out_P = 0. endif end subroutine search_other_column_discontinuous @@ -1411,9 +1514,13 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) real, intent(in) :: dRhoPos !< Positive density difference real, intent(in) :: Ppos !< Position of positive density difference - if (PposdRhoPos) write(0,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos - if (dRhoNeg>dRhoPos) stop 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos' + if (PposdRhoPos) then + write(0,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos + elseif (dRhoNeg>dRhoPos) then + stop 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos' + endif if (Ppos<=Pneg) then ! Handle vanished or inverted layers interpolate_for_nondim_position = 0.5 elseif ( dRhoPos - dRhoNeg > 0. ) then @@ -1433,341 +1540,6 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) if ( interpolate_for_nondim_position > 1. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' end function interpolate_for_nondim_position -!> Use root-finding methods to find where dRho = 0, based on the equation of state and the polynomial -!! reconstructions of temperature, salinity. Initial guess is based on the zero crossing of based on linear -!! profiles of dRho, T, and S, between the top and bottom interface. If second derivatives of the EOS are available, -!! it starts with a Newton's method. However, Newton's method is not guaranteed to be bracketed, a check is performed -!! to see if it it diverges outside the interval. In that case (or in the case that second derivatives are not -!! available), Brent's method is used following the implementation found at -!! https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.f90 -real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, deg, & - ppoly_T, ppoly_S, EOS, x0, drho_top, drho_bot, min_bound, ref_pres, force_brent) - integer, intent(in) :: max_iter !< Number of maximum iterations to use - real, intent(in) :: tolerance !< Convergence criterion for delta_rho - real, intent(in) :: T_ref !< Temperature of the neutral surface at the searched from interface - real, intent(in) :: S_ref !< Salinity of the neutral surface at the searched from interface - real, intent(in) :: alpha_ref !< dRho/dT of the neutral surface at the searched from interface - real, intent(in) :: beta_ref !< dRho/dS of the neutral surface at the searched from interface - real, intent(in) :: P_top !< Pressure at the top interface in the layer to be searched - real, intent(in) :: P_bot !< Pressure at the bottom interface in the layer to be searched - integer, intent(in) :: deg !< Order of the polynomimal used for reconstructions - real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the order N polynomial reconstruction of T within - !! the layer to be searched. - real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the order N polynomial reconstruction of T within - !! the layer to be searched. - real, intent(in) :: x0 !< Nondimensional position within the layer where the neutral - !! surface connects. If interpolate_for_nondim_position was - !! previously called, this would be based on linear profile of dRho - real, intent(in) :: drho_top, drho_bot, min_bound - real, intent(in) :: ref_pres !< Optionally use a different reference pressure other than local - type(EOS_type), pointer :: EOS !< Equation of state structure - logical, optional, intent(in) :: force_brent !< Forces the use of Brent's method instead of Newton's method to find - !! position of neutral surface - - ! Local variables - integer :: form_of_EOS - integer :: iter - logical :: do_newton, do_brent - - real :: delta_rho, d_delta_rho_dP ! Terms for the Newton iteration - real :: P_int, P_min, P_ref ! Interpolated pressure - real :: delta_rho_init, delta_rho_final, x_init - real :: T, S, alpha, beta, alpha_avg, beta_avg - ! Newton's Method variables - real :: dT_dP, dS_dP, delta_T, delta_S, delta_P - real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP - ! Brent's Method variables - real :: a, b, c, d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep - - real :: P_last - logical :: debug = .false. - if (ref_pres>=0.) P_ref = ref_pres - delta_P = P_bot-P_top - refine_nondim_position = min_bound - x_init = refine_nondim_position - - call extract_member_EOS(EOS, form_of_EOS = form_of_EOS) - do_newton = (form_of_EOS == EOS_LINEAR) .or. (form_of_EOS == EOS_TEOS10) .or. (form_of_EOS == EOS_WRIGHT) - do_brent = .not. do_newton - if (present(force_brent)) then - do_newton = .not. force_brent - do_brent = force_brent - endif - - ! Check to make sure that a root exists between the minimum bound and the bottom of the layer - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, refine_nondim_position, & - ref_pres, EOS, delta_rho) - delta_rho_init = delta_rho - if ( SIGN(1.,delta_rho) == SIGN(1.,drho_bot) ) then - ! Return the position of min_bound if closer to 0 than drho_bot - if (ABS(delta_rho) < ABS(drho_bot)) then - refine_nondim_position = min_bound - else - refine_nondim_position = 1. - endif - do_newton = .false. ; do_brent = .false. - endif - - if (debug) then - write (*,*) "------" - write (*,*) "Starting delta_rho: ", delta_rho - endif - - ! For now only linear, Wright, and TEOS-10 equations of state have functions providing second derivatives and - ! thus can use Newton's method for the equation of state - if (do_newton) then - ! Set lower bound of pressure - P_min = P_top*(1.-min_bound) + P_bot*(min_bound) - ! Iterate over Newton's method for the function: x0 = x0 - delta_rho/d_delta_rho_dP - do iter = 1, max_iter - ! Evaluate delta_rho(x0) - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & - refine_nondim_position, ref_pres, EOS, delta_rho, P_int, T, S, alpha_avg, & - beta_avg, delta_T, delta_S) - ! Check for convergence - if (ABS(delta_rho) <= tolerance) then - do_brent = .false. - exit - endif - ! Evaluate total derivative of delta_rho - if (ref_pres<0.) P_ref = P_int - call calculate_density_second_derivs( T, S, P_ref, dbeta_dS, dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, EOS ) - ! In the case of a constant reference pressure, no dependence on neutral direction with pressure - if (ref_pres>=0.) then - dalpha_dP = 0. ; dbeta_dP = 0. - endif - dalpha_dS = dbeta_dT ! Cross derivatives are identicial - ! By chain rule dT_dP= (dT_dz)*(dz/dP) = dT_dz / (Pbot-Ptop) - dT_dP = first_derivative_polynomial( ppoly_T, deg+1, refine_nondim_position ) / delta_P - dS_dP = first_derivative_polynomial( ppoly_S, deg+1, refine_nondim_position ) / delta_P - ! Total derivative of d_delta_rho wrt P - d_delta_rho_dP = 0.5*( delta_S*(dS_dP*dbeta_dS + dT_dP*dbeta_dT + dbeta_dP) + & - ( delta_T*(dS_dP*dalpha_dS + dT_dP*dalpha_dT + dalpha_dP))) + & - dS_dP*beta_avg + dT_dP*alpha_avg - if (d_delta_rho_dP == 0.) then - do_brent = .true. - exit - endif - ! Newton step update - P_last = P_int - P_int = P_int - (delta_rho / d_delta_rho_dP) - if (P_int < P_min .or. P_int > P_bot) then - if (debug) then - write (*,*) "Iteration: ", iter - write (*,*) "delta_rho, d_delta_rho_dP: ", delta_rho, d_delta_rho_dP - write (*,*) "T, T Poly Coeffs: ", T, ppoly_T - write (*,*) "S, S Poly Coeffs: ", S, ppoly_S - write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref - write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref - write (*,*) "P, dT_dP, dS_dP:", P_int, dT_dP, dS_dP - write (*,*) "dRhoTop, dRhoBot:", drho_top, drho_bot - write (*,*) "x0: ", x0 - write (*,*) "refine_nondim_position: ", refine_nondim_position - write (*,*) - endif -! call MOM_error(WARNING, "Step went out of bounds") - ! Switch to Brent's method by setting the converged flag to false - do_brent = .true. - ! Reset to first guess if already diverged - if (ABS(delta_rho_init)1.) then - if (debug) then - write (*,*) "T, T Poly Coeffs: ", T, ppoly_T - write (*,*) "S, S Poly Coeffs: ", S, ppoly_S - write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref - write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref - write (*,*) "P, dT_dP, dS_dP:", P_int, dT_dP, dS_dP - write (*,*) "x0: ", x0 - write (*,*) "refine_nondim_position: ", refine_nondim_position - endif - call MOM_error(WARNING, "refine_nondim_position>1.") - refine_nondim_position = MAX(x0,min_bound) - endif - - if (refine_nondim_position<0.) then - if (debug) then - write (*,*) "T, T Poly Coeffs: ", T, ppoly_T - write (*,*) "S, S Poly Coeffs: ", S, ppoly_S - write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref - write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref - write (*,*) "dT_dP, dS_dP:", dT_dP, dS_dP - write (*,*) "x0: ", x0 - write (*,*) "refine_nondim_position: ", refine_nondim_position - endif - call MOM_error(WARNING, "refine_nondim_position<0.") - refine_nondim_position = MAX(x0,min_bound) - endif - - if (debug) then - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & - refine_nondim_position, ref_pres, EOS, delta_rho) - write (*,*) "End delta_rho: ", delta_rho - write (*,*) "x0, delta_x: ", x0, refine_nondim_position-x0 - write (*,*) "Iterations: ", iter - write (*,*) "******" - endif - -end function refine_nondim_position - -!> Calculate the difference in neutral density between a reference T, S, alpha, and beta -!! and a point on the polynomial reconstructions of T, S -subroutine calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, x0, ref_pres, EOS, & - delta_rho, P_out, T_out, S_out, alpha_avg_out, beta_avg_out, delta_T_out, delta_S_out) - integer, intent(in) :: deg !< Degree of polynomial reconstruction - real, intent(in) :: T_ref !< Temperature at reference surface - real, intent(in) :: S_ref !< Salinity at reference surface - real, intent(in) :: alpha_ref !< dRho/dT at reference surface - real, intent(in) :: beta_ref !< dRho/dS at reference surface - real, intent(in) :: P_top !< Pressure (Pa) at top interface of layer to be searched - real, intent(in) :: P_bot !< Pressure (Pa) at bottom interface - real, dimension(deg+1), intent(in) :: ppoly_T !< Coefficients of T reconstruction - real, dimension(deg+1), intent(in) :: ppoly_S !< Coefficients of S reconstruciton - real, intent(in) :: x0 !< Nondimensional position to evaluate - real, intent(in) :: ref_pres !< Reference pressure - type(EOS_type), pointer :: EOS !< Equation of state structure - real, intent(out) :: delta_rho - real, optional, intent(out) :: P_out !< Pressure at point x0 - real, optional, intent(out) :: T_out !< Temperature at point x0 - real, optional, intent(out) :: S_out !< Salinity at point x0 - real, optional, intent(out) :: alpha_avg_out !< Average of alpha between reference and x0 - real, optional, intent(out) :: beta_avg_out !< Average of beta between reference and x0 - real, optional, intent(out) :: delta_T_out !< Difference in temperature between reference and x0 - real, optional, intent(out) :: delta_S_out !< Difference in salinity between reference and x0 - - real :: alpha, beta, alpha_avg, beta_avg, P_int, T, S, delta_T, delta_S - - P_int = (1. - x0)*P_top + x0*P_bot - T = evaluation_polynomial( ppoly_T, deg+1, x0 ) - S = evaluation_polynomial( ppoly_S, deg+1, x0 ) - ! Interpolated pressure if using locally referenced neutral density - if (ref_pres<0.) then - call calculate_density_derivs( T, S, P_int, alpha, beta, EOS ) - else - ! Constant reference pressure (isopycnal) - call calculate_density_derivs( T, S, ref_pres, alpha, beta, EOS ) - endif - - ! Calculate the f(P) term for Newton's method - alpha_avg = 0.5*( alpha + alpha_ref ) - beta_avg = 0.5*( beta + beta_ref ) - delta_T = T - T_ref - delta_S = S - S_ref - delta_rho = alpha_avg*delta_T + beta_avg*delta_S - - ! If doing a Newton step, these quantities are needed, otherwise they can just be optional - if (present(P_out)) P_out = P_int - if (present(T_out)) T_out = T - if (present(S_out)) S_out = S - if (present(alpha_avg_out)) alpha_avg_out = alpha_avg - if (present(beta_avg_out)) beta_avg_out = beta_avg - if (present(delta_T_out)) delta_T_out = delta_T - if (present(delta_S_out)) delta_S_out = delta_S - -end subroutine calc_delta_rho - !> Returns a single column of neutral diffusion fluxes of a tracer. subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, hEff, Flx, continuous, remap_CS) integer, intent(in) :: nk !< Number of levels @@ -2162,7 +1934,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) type(remapping_CS), pointer :: remap_CS ! Remapping control structure (PLM) real, dimension(nk,2) :: poly_T_l, poly_T_r, poly_S, poly_slope ! Linear reconstruction for T real, dimension(nk,2) :: dRdT, dRdS + logical, dimension(nk) :: stable_l, stable_r integer :: iMethod + integer :: ns_l, ns_r integer :: k logical :: v @@ -2182,10 +1956,13 @@ logical function ndiff_unit_tests_discontinuous(verbose) do k = 1,nk ; Pres_l(k+1) = Pres_l(k) + hL(k) ; Pres_r(k+1) = Pres_r(k) + hR(k) ; enddo ! Identical columns Tl = (/20.,16.,12./) ; Tr = (/20.,16.,12./) + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoL (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR @@ -2194,10 +1971,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns') Tl = (/20.,16.,12./) ; Tr = (/18.,14.,10./) + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoR @@ -2206,10 +1985,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column slightly cooler') Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) ; + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoL (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoR @@ -2218,10 +1999,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Left column slightly cooler') Tl = (/20.,16.,12./) ; Tr = (/14.,10.,6./) + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,2,3,3,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,1,1,2,2,2,3,3/), & ! KoR @@ -2230,10 +2013,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column somewhat cooler') Tl = (/20.,16.,12./) ; Tr = (/8.,6.,4./) + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,3,3,3,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,1,1,1,2,2,3,3/), & ! KoR @@ -2242,10 +2027,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column much cooler') Tl = (/14.,14.,10./) ; Tr = (/14.,14.,10./) + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoL (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR @@ -2254,10 +2041,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns with mixed layer') Tl = (/20.,16.,12./) ; Tr = (/14.,14.,10./) + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,2,3,3,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,1,2,2,2,3,3,3/), & ! KoR @@ -2266,27 +2055,33 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column with mixed layer') Tl = (/14.,14.,6./) ; Tr = (/12.,16.,8./) + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) - ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & - (/1,1,2,2,3,3,3,3,3,3,3,3/), & ! KoL - (/1,1,1,1,1,1,2,2,3,3,3,3/), & ! KoR - (/0.0, 1.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, .75, 1.0/), & ! pL - (/0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, .25, 1.0, 1.0/), & ! pR - (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 7.5, 0.0/), & ! hEff + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 10, KoL, KoR, PoL, PoR, hEff, & + (/1,1,1,1,2,2,2,3,3,3/), & ! KoL + (/2,2,2,2,2,2,3,3,3,3/), & ! KoR + (/0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 1.0, 0.0, .75, 1.0/), & ! pL + (/0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, .25, 1.0, 1.0/), & ! pR + (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 7.5, 0.0/), & ! hEff 'Left mixed layer, right unstable mixed layer') + + Tl = (/10.,11.,6./) ; Tr = (/12.,13.,8./) Til(:,1) = (/8.,12.,10./) ; Til(:,2) = (/12.,10.,2./) Tir(:,1) = (/10.,14.,12./) ; TiR(:,2) = (/14.,12.,4./) - call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & - Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) - ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & - (/1,1,1,1,1,1,1,2,2,3,3,3/), & ! KoL - (/1,1,2,2,3,3,3,3,3,3,3,3/), & ! KoR - (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, .75, 1.0/), & ! pL - (/0.0, 1.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, .25, .25, 1.0, 1.0/), & ! pR - (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 4.0, 0.0, 7.5, 0.0/), & ! hEff + call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 8, KoL, KoR, PoL, PoR, hEff, & + (/2,2,2,2,2,3,3,3/), & ! KoL + (/2,2,2,3,3,3,3,3/), & ! KoR + (/0.0, 0.0, 0.0, 0.0, 1.0, 0.0, .75, 1.0/), & ! pL + (/0.0, 1.0, 1.0, 0.0, .25, .25, 1.0, 1.0/), & ! pR + (/0.0, 0.0, 0.0, 4.0, 0.0, 7.5, 0.0/), & ! hEff 'Two unstable mixed layers') deallocate(remap_CS) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 new file mode 100644 index 0000000000..61ffd8e6d4 --- /dev/null +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -0,0 +1,489 @@ +!> A column-wise toolbox for implementing neutral diffusion +module MOM_neutral_diffusion_aux + +use MOM_EOS, only : EOS_type, extract_member_EOS, EOS_LINEAR, EOS_TEOS10, EOS_WRIGHT +use MOM_EOS, only : calculate_density_derivs, calculate_density_second_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial + +! This file is part of MOM6. See LICENSE.md for the license. +implicit none ; private + +public mark_unstable_cells +public mark_unstable_cells_i +public calc_delta_rho +public refine_nondim_position +public check_neutral_positions + +contains + +!> Given the reconsturcitons of dRdT, dRdS, T, S mark the cells which are stably stratified parts of the water column +!! For an layer to be unstable the top interface must be denser than the bottom or the bottom interface of the layer +!! +subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) + integer, intent(in) :: nk !< Number of levels in a column + real, dimension(nk), intent(in) :: dRdT !< drho/dT (kg/m3/degC) + real, dimension(nk), intent(in) :: dRdS !< drho/dS (kg/m3/ppt) + real, dimension(nk), intent(in) :: T !< drho/dS (kg/m3/ppt) + real, dimension(nk), intent(in) :: S !< drho/dS (kg/m3/ppt) + logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified + integer, intent( out) :: ns !< Number of neutral surfaces in unmasked part of the column + + integer :: k, first_stable, prev_stable + real :: delta_rho + + ns = 0 + ! If only one cell, then we really shouldn't do anything + if (nk==1) then + stable_cell(nk)=.true. + ns = 2 + return + endif + + ! First sweep down and find the first place where the column is stable + do k=1,nk-1 + delta_rho = ( (dRdT(k) + dRdT(k+1))*(T(k)-T(k+1)) ) + ( (dRdS(k) + dRdS(k+1))*(S(k)-S(k+1)) ) + if (delta_rho <= 0.) then + first_stable = k+1 + prev_stable = k + stable_cell(k) = .true. + ns = ns + 2 + exit + else + stable_cell(k) = .false. + endif + enddo + + ! Loop through the rest of the column + do k=first_stable,nk + delta_rho = ( (dRdT(prev_stable) + dRdT(k))*(T(prev_stable)-T(k)) ) + ( (dRdS(prev_stable) + dRdS(k))*(S(prev_stable)-S(k)) ) + if (delta_rho <= 0.) then + stable_cell(k) = .true. + prev_stable = k + ns = ns + 2 + else + stable_cell(k) = .false. + endif + enddo + +end subroutine mark_unstable_cells + +subroutine mark_unstable_cells_i(nk, dRdT, dRdS,T, S, stable_cell, ns) + integer, intent(in) :: nk !< Number of levels in a column + real, dimension(nk,2), intent(in) :: dRdT !< drho/dT (kg/m3/degC) + real, dimension(nk,2), intent(in) :: dRdS !< drho/dS (kg/m3/ppt) + real, dimension(nk,2), intent(in) :: T !< drho/dS (kg/m3/ppt) + real, dimension(nk,2), intent(in) :: S !< drho/dS (kg/m3/ppt) + logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified + integer, intent( out) :: ns !< Number of neutral surfaces in unmasked part of the column + + integer :: k, first_stable, prev_stable + real :: delta_rho + + ! If only one cell, then we really shouldn't do anything + if (nk==1) then + stable_cell(nk)=.true. + ns = 2 + return + endif + + do k=1,nk + ! Only check cell which are stable + if (stable_cell(k)) then + delta_rho = ( (dRdT(k,1) + dRdT(k,2))*(T(k,1)-T(k,2)) ) + ( (dRdS(k,1) + dRdS(k,2))*(S(k,1)-S(k,2)) ) + if (delta_rho > 0.) then + stable_cell(k) = .false. + ns = ns - 2 + endif + endif + enddo + +end subroutine mark_unstable_cells_i + +!> Calculate the difference in neutral density between a reference T, S, alpha, and beta +!! and a point on the polynomial reconstructions of T, S +subroutine calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, x0, ref_pres, EOS, & + delta_rho, P_out, T_out, S_out, alpha_avg_out, beta_avg_out, delta_T_out, delta_S_out) + integer, intent(in) :: deg !< Degree of polynomial reconstruction + real, intent(in) :: T_ref !< Temperature at reference surface + real, intent(in) :: S_ref !< Salinity at reference surface + real, intent(in) :: alpha_ref !< dRho/dT at reference surface + real, intent(in) :: beta_ref !< dRho/dS at reference surface + real, intent(in) :: P_top !< Pressure (Pa) at top interface of layer to be searched + real, intent(in) :: P_bot !< Pressure (Pa) at bottom interface + real, dimension(deg+1), intent(in) :: ppoly_T !< Coefficients of T reconstruction + real, dimension(deg+1), intent(in) :: ppoly_S !< Coefficients of S reconstruciton + real, intent(in) :: x0 !< Nondimensional position to evaluate + real, intent(in) :: ref_pres !< Reference pressure + type(EOS_type), pointer :: EOS !< Equation of state structure + real, intent(out) :: delta_rho + real, optional, intent(out) :: P_out !< Pressure at point x0 + real, optional, intent(out) :: T_out !< Temperature at point x0 + real, optional, intent(out) :: S_out !< Salinity at point x0 + real, optional, intent(out) :: alpha_avg_out !< Average of alpha between reference and x0 + real, optional, intent(out) :: beta_avg_out !< Average of beta between reference and x0 + real, optional, intent(out) :: delta_T_out !< Difference in temperature between reference and x0 + real, optional, intent(out) :: delta_S_out !< Difference in salinity between reference and x0 + + real :: alpha, beta, alpha_avg, beta_avg, P_int, T, S, delta_T, delta_S + + P_int = (1. - x0)*P_top + x0*P_bot + T = evaluation_polynomial( ppoly_T, deg+1, x0 ) + S = evaluation_polynomial( ppoly_S, deg+1, x0 ) + ! Interpolated pressure if using locally referenced neutral density + if (ref_pres<0.) then + call calculate_density_derivs( T, S, P_int, alpha, beta, EOS ) + else + ! Constant reference pressure (isopycnal) + call calculate_density_derivs( T, S, ref_pres, alpha, beta, EOS ) + endif + + ! Calculate the f(P) term for Newton's method + alpha_avg = 0.5*( alpha + alpha_ref ) + beta_avg = 0.5*( beta + beta_ref ) + delta_T = T - T_ref + delta_S = S - S_ref + delta_rho = alpha_avg*delta_T + beta_avg*delta_S + + ! If doing a Newton step, these quantities are needed, otherwise they can just be optional + if (present(P_out)) P_out = P_int + if (present(T_out)) T_out = T + if (present(S_out)) S_out = S + if (present(alpha_avg_out)) alpha_avg_out = alpha_avg + if (present(beta_avg_out)) beta_avg_out = beta_avg + if (present(delta_T_out)) delta_T_out = delta_T + if (present(delta_S_out)) delta_S_out = delta_S + +end subroutine calc_delta_rho + +!> Use root-finding methods to find where dRho = 0, based on the equation of state and the polynomial +!! reconstructions of temperature, salinity. Initial guess is based on the zero crossing of based on linear +!! profiles of dRho, T, and S, between the top and bottom interface. If second derivatives of the EOS are available, +!! it starts with a Newton's method. However, Newton's method is not guaranteed to be bracketed, a check is performed +!! to see if it it diverges outside the interval. In that case (or in the case that second derivatives are not +!! available), Brent's method is used following the implementation found at +!! https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.f90 +real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, deg, & + ppoly_T, ppoly_S, EOS, x0, drho_top, drho_bot, min_bound, ref_pres, force_brent) + integer, intent(in) :: max_iter !< Number of maximum iterations to use + real, intent(in) :: tolerance !< Convergence criterion for delta_rho + real, intent(in) :: T_ref !< Temperature of the neutral surface at the searched from interface + real, intent(in) :: S_ref !< Salinity of the neutral surface at the searched from interface + real, intent(in) :: alpha_ref !< dRho/dT of the neutral surface at the searched from interface + real, intent(in) :: beta_ref !< dRho/dS of the neutral surface at the searched from interface + real, intent(in) :: P_top !< Pressure at the top interface in the layer to be searched + real, intent(in) :: P_bot !< Pressure at the bottom interface in the layer to be searched + integer, intent(in) :: deg !< Order of the polynomimal used for reconstructions + real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the order N polynomial reconstruction of T within + !! the layer to be searched. + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the order N polynomial reconstruction of T within + !! the layer to be searched. + real, intent(in) :: x0 !< Nondimensional position within the layer where the neutral + !! surface connects. If interpolate_for_nondim_position was + !! previously called, this would be based on linear profile of dRho + real, intent(in) :: drho_top, drho_bot, min_bound + real, intent(in) :: ref_pres !< Optionally use a different reference pressure other than local + type(EOS_type), pointer :: EOS !< Equation of state structure + logical, optional, intent(in) :: force_brent !< Forces the use of Brent's method instead of Newton's method to find + !! position of neutral surface + + ! Local variables + integer :: form_of_EOS + integer :: iter + logical :: do_newton, do_brent + + real :: delta_rho, d_delta_rho_dP ! Terms for the Newton iteration + real :: P_int, P_min, P_ref ! Interpolated pressure + real :: delta_rho_init, delta_rho_final, x_init + real :: T, S, alpha, beta, alpha_avg, beta_avg + ! Newton's Method variables + real :: dT_dP, dS_dP, delta_T, delta_S, delta_P + real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP + ! Brent's Method variables + real :: a, b, c, d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep + + real :: P_last + logical :: debug = .false. + if (ref_pres>=0.) P_ref = ref_pres + delta_P = P_bot-P_top + refine_nondim_position = min_bound + x_init = refine_nondim_position + + call extract_member_EOS(EOS, form_of_EOS = form_of_EOS) + do_newton = (form_of_EOS == EOS_LINEAR) .or. (form_of_EOS == EOS_TEOS10) .or. (form_of_EOS == EOS_WRIGHT) + do_brent = .not. do_newton + if (present(force_brent)) then + do_newton = .not. force_brent + do_brent = force_brent + endif + + ! Check to make sure that a root exists between the minimum bound and the bottom of the layer + call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, refine_nondim_position, & + ref_pres, EOS, delta_rho) + delta_rho_init = delta_rho +! if ( SIGN(1.,delta_rho) == SIGN(1.,drho_bot) ) then +! ! Return the position of min_bound if closer to 0 than drho_bot +! if (ABS(delta_rho) < ABS(drho_bot)) then +! refine_nondim_position = min_bound +! else +! refine_nondim_position = 1. +! endif +! do_newton = .false. ; do_brent = .false. +! endif + + if (debug) then + write (*,*) "------" + write (*,*) "Starting delta_rho: ", delta_rho + endif + + ! For now only linear, Wright, and TEOS-10 equations of state have functions providing second derivatives and + ! thus can use Newton's method for the equation of state + if (do_newton) then + refine_nondim_position = min_bound + ! Set lower bound of pressure + P_min = P_top*(1.-min_bound) + P_bot*(min_bound) + ! Iterate over Newton's method for the function: x0 = x0 - delta_rho/d_delta_rho_dP + do iter = 1, max_iter + ! Evaluate delta_rho(x0) + call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & + refine_nondim_position, ref_pres, EOS, delta_rho, P_int, T, S, alpha_avg, & + beta_avg, delta_T, delta_S) + ! Check for convergence + if (ABS(delta_rho) <= tolerance) then + do_brent = .false. + exit + endif + ! Evaluate total derivative of delta_rho + if (ref_pres<0.) P_ref = P_int + call calculate_density_second_derivs( T, S, P_ref, dbeta_dS, dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, EOS ) + ! In the case of a constant reference pressure, no dependence on neutral direction with pressure + if (ref_pres>=0.) then + dalpha_dP = 0. ; dbeta_dP = 0. + endif + dalpha_dS = dbeta_dT ! Cross derivatives are identicial + ! By chain rule dT_dP= (dT_dz)*(dz/dP) = dT_dz / (Pbot-Ptop) + dT_dP = first_derivative_polynomial( ppoly_T, deg+1, refine_nondim_position ) / delta_P + dS_dP = first_derivative_polynomial( ppoly_S, deg+1, refine_nondim_position ) / delta_P + ! Total derivative of d_delta_rho wrt P + d_delta_rho_dP = 0.5*( delta_S*(dS_dP*dbeta_dS + dT_dP*dbeta_dT + dbeta_dP) + & + ( delta_T*(dS_dP*dalpha_dS + dT_dP*dalpha_dT + dalpha_dP))) + & + dS_dP*beta_avg + dT_dP*alpha_avg + if (d_delta_rho_dP == 0.) then + do_brent = .true. + exit + endif + ! Newton step update + P_last = P_int + P_int = P_int - (delta_rho / d_delta_rho_dP) + if (P_int < P_min .or. P_int > P_bot) then + if (debug) then + write (*,*) "Iteration: ", iter + write (*,*) "delta_rho, d_delta_rho_dP: ", delta_rho, d_delta_rho_dP + write (*,*) "T, T Poly Coeffs: ", T, ppoly_T + write (*,*) "S, S Poly Coeffs: ", S, ppoly_S + write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref + write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref + write (*,*) "P, dT_dP, dS_dP:", P_int, dT_dP, dS_dP + write (*,*) "dRhoTop, dRhoBot:", drho_top, drho_bot + write (*,*) "x0: ", x0 + write (*,*) "refine_nondim_position: ", refine_nondim_position + write (*,*) + endif +! call MOM_error(WARNING, "Step went out of bounds") + ! Switch to Brent's method by setting the converged flag to false + do_brent = .true. + ! Reset to first guess if already diverged +! if (ABS(delta_rho_init)1.) then + if (debug) then + write (*,*) "T, T Poly Coeffs: ", T, ppoly_T + write (*,*) "S, S Poly Coeffs: ", S, ppoly_S + write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref + write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref + write (*,*) "P, dT_dP, dS_dP:", P_int, dT_dP, dS_dP + write (*,*) "x0: ", x0 + write (*,*) "refine_nondim_position: ", refine_nondim_position + endif + call MOM_error(WARNING, "refine_nondim_position>1.") + refine_nondim_position = MAX(x0,min_bound) + endif + + if (refine_nondim_position<0.) then + if (debug) then + write (*,*) "T, T Poly Coeffs: ", T, ppoly_T + write (*,*) "S, S Poly Coeffs: ", S, ppoly_S + write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref + write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref + write (*,*) "dT_dP, dS_dP:", dT_dP, dS_dP + write (*,*) "x0: ", x0 + write (*,*) "refine_nondim_position: ", refine_nondim_position + endif + call MOM_error(WARNING, "refine_nondim_position<0.") + refine_nondim_position = MAX(x0,min_bound) + endif + + if (debug) then + call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & + refine_nondim_position, ref_pres, EOS, delta_rho) + write (*,*) "End delta_rho: ", delta_rho + write (*,*) "x0, delta_x: ", x0, refine_nondim_position-x0 + write (*,*) "refine_nondim_position: ", refine_nondim_position + write (*,*) "Iterations: ", iter + write (*,*) "******" + endif + +end function refine_nondim_position + +!> Returns .true. if the endpoints of neutral surface do not have the same density (within a specified tolerance) +logical function check_neutral_positions(deg, EOS, x_l, T_poly_l, S_poly_l, P_l, x_r, T_poly_r, S_poly_r, P_r, tolerance, ref_pres) + integer :: deg !< Degree of polynomial + type(EOS_type), pointer :: EOS + real :: x_l !< Nondim position within layer (left) + real, dimension(deg+1) :: T_poly_l !< Coefficients of polynomial reconstructions of T (left) + real, dimension(deg+1) :: S_poly_l !< Coefficients of polynomial reconstructions of S (left) + real, dimension(2) :: P_l !< Pressure at top and bottom of layer (left) + real :: x_r !< Nondim position within layer (left) + real, dimension(deg+1) :: T_poly_r !< Coefficients of polynomial reconstructions of T (right) + real, dimension(deg+1) :: S_poly_r !< Coefficients of polynomial reconstructions of S (right) + real, dimension(2) :: P_r !< Pressure at top and bottom of layer (right) + real :: tolerance !< How close to the difference in density should be + real, optional :: ref_pres !< reference pressure if not usign local pressure + + real :: delta_rho + real :: Pl, Tl, Sl, alpha_l, beta_l + real :: Pr, Tr, Sr, alpha_r, beta_r + + Tl = evaluation_polynomial( T_poly_l, deg+1, x_l ) + Tr = evaluation_polynomial( T_poly_r, deg+1, x_r ) + Sl = evaluation_polynomial( S_poly_l, deg+1, x_l ) + Sr = evaluation_polynomial( S_poly_r, deg+1, x_r ) + + if (ref_pres>0.) then + call calculate_density_derivs( Tl, Sl, ref_pres, alpha_l, beta_l, EOS ) + call calculate_density_derivs( Tr, Sr, ref_pres, alpha_r, beta_r, EOS ) + else + Pl = (1. - x_l)*P_l(1) + x_l*P_l(2) + Pr = (1. - x_r)*P_r(1) + x_l*P_r(2) + call calculate_density_derivs( Tl, Sl, Pl, alpha_l, beta_l, EOS ) + call calculate_density_derivs( Tr, Sr, Pr, alpha_r, beta_r, EOS ) + endif + + delta_rho = 0.5*( (alpha_l+alpha_r)*(Tl-Tr) + (beta_l+beta_r)*(Sl-Sr) ) + check_neutral_positions = ABS(delta_rho)>tolerance + + if (check_neutral_positions) then + print *, "Density difference of", delta_rho + endif + +end function check_neutral_positions + +end module MOM_neutral_diffusion_aux From dc485ba427208ed9965fb5be45b42401e0d83105 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 16 Oct 2017 18:16:23 -0400 Subject: [PATCH 002/170] Simplify logic in discontinuous neutral diffusion --- src/tracer/MOM_neutral_diffusion.F90 | 210 +++++++++++++++++++-------- 1 file changed, 148 insertions(+), 62 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 491e0454b7..5ae41e4207 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -385,6 +385,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) CS%S_i(:,:,:,:) = 0. CS%dRdT_i(:,:,:,:) = 0. CS%dRdS_i(:,:,:,:) = 0. + CS%ns(:,:) = 0. + CS%stable_cell(:,:,:) = .true. endif ! Calculate pressure at interfaces and layer averaged alpha/beta @@ -429,15 +431,16 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) else ! Discontinuous reconstruction do k = 1, G%ke if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) - call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & - CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, EOS) + if (CS%stable_cell(i,j,k)) & + call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & + CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, EOS) if (CS%ref_pres<0) then ref_pres(:) = CS%Pint(:,j,k+1) endif - call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & - CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, EOS) + if (CS%stable_cell(i,j,k)) & + call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & + CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, EOS) enddo - call mark_unstable_cells_i( G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) endif enddo @@ -1125,15 +1128,15 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, logical :: refine_pos ! Use rootfinding to find the true neutral surface position integer :: k, kl_left_0, kl_right_0 real :: dRho, dRhoTop, dRhoBot, dRhoTopm1, hL, hR - integer :: lastK_left, lastK_right, maxK_left, maxK_right - real :: lastP_left, lastP_right + integer :: lastK_left, lastK_right, maxP_r + real :: lastP_left, lastP_right, maxP_l real :: min_bound logical, dimension(nk) :: top_connected_l, top_connected_r logical, dimension(nk) :: bot_connected_l, bot_connected_r + logical :: search_layer_l, search_layer_r top_connected_l(:) = .false. ; top_connected_r(:) = .false. bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. - maxK_left = -1 ; maxK_right = -1 ! Vectors with all the values of the discontinuous reconstruction. ! Dimensions are [number of layers x number of interfaces]. Second dimension = 1 for top interface, = 2 for bottom ! real, dimension(nk,2) :: Sl, Sr, Tl, Tr, dRdT_l, dRdS_l, dRdT_r, dRdS_r @@ -1209,7 +1212,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, dRhoBot = 0.5 * & ( ( dRdT_l(kl_left,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left,2) - Tr(kl_right,ki_right) ) & + ( dRdS_l(kl_left,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left,2) - Sr(kl_right,ki_right) ) ) - if (kl_left>kl_left_0) then + if (.not. search_layer_l .and. kl_left>kl_left_0) then if (stable_l(kl_left-1) ) then ! Calculate the density difference at top of discontinuity dRhoTopm1 = 0.5 * & ( ( dRdT_l(kl_left-1,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left-1,2) - Tr(kl_right,ki_right) ) & @@ -1229,7 +1232,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, ! Set the position within the starting column PoR(k_surface) = REAL(ki_right-1) - KoR(k_surface) = REAL(kl_right) + KoR(k_surface) = kl_right ! Set position within the searched column call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & @@ -1278,7 +1281,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, endif ! Set the position within the starting column PoL(k_surface) = REAL(ki_left-1) - KoL(k_surface) = REAL(kl_left) + KoL(k_surface) = kl_left ! Set position within the searched column call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), & @@ -1307,8 +1310,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, if (debug_this_module) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & KoR(k_surface), " PoR:", PoR(k_surface) - maxK_left= MAX(KoL(k_surface), maxK_left) - maxK_right= MAX(KoR(k_surface), maxK_right) ! Effective thickness ! NOTE: This would be better expressed in terms of the layers thicknesses rather ! than as differences of position - AJA @@ -1369,10 +1370,10 @@ subroutine increment_interface(nk, kl, ki, stable, reached_bottom, searching_thi if (ki == 1) then ki = 2 elseif ((ki == 2) .and. (kl < nk) ) then - ki = 1 do k = kl+1,nk if (stable(kl)) then kl = k + ki = 1 exit endif ! If we did not find another stable cell, then the current cell is essentially the bottom @@ -1412,61 +1413,146 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, ! Local variables logical :: search_layer - search_layer = .true. - ! Bad values to make sure that the particular setup has been processed - out_P = -1. ; out_K = -1 - ! Check if everything in this layer is denser than neutral surface or if at the top of the water column - if ((kl==kl_0 .and. ki==1)) then - if (debug_this_module) write(*,*) "At surface" - out_P = 0. ; out_K = kl - search_layer = .false. - ! Deal with the case where reconstruction is continuous - elseif ( kl>kl_0 .and. lastK 0.)) then - out_P = 1. ; out_K = kl-1 - search_layer = .false. - endif - endif - if (search_layer) then - if (dRhoTop > 0.) then - if (debug_this_module) write(*,*) "dRhoTop > 0." - if (lastK < kl) then - out_P = 0. ; out_K = kl - elseif (lastK == kl) then - out_P = lastP ; out_K = lastK + if (kl > kl_0) then ! Away from top cell + if (kl == lastK) then ! Searching in the same layer + if (dRhoTop > 0.) then + out_P = lastP ; out_K = kl + elseif (dRhoTop == dRhoBot) then + if (top_connected(kl)) then + out_P = 1. ; out_K = kl + else + out_P = 0. ; out_K = kl + endif + elseif (dRhoTop >= dRhoBot) then + out_P = 1. ; out_K = kl + else + out_K = kl + out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) endif - elseif ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then - if (debug_this_module) write(*,*) "dRhoTop == 0. .and. not top_connected" -! if ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then - if (lastK < kl) then - out_P = 0. ; out_K = kl - elseif (lastK == kl) then - out_P = lastP ; out_K = lastK + else ! Searching across the interface + if (.not. bot_connected(kl-1) ) then + out_K = kl-1 + out_P = 1. + else + out_K = kl + out_P = 0. + endif + endif + else ! At the top cell + if (ki == 1) then + out_P = 0. ; out_K = kl + elseif (dRhoTop > 0.) then + out_P = max(0.,lastP) ; out_K = kl + elseif (dRhoTop == dRhoBot) then + if (top_connected(kl)) then + out_P = 1. ; out_K = kl + else + out_P = max(0.,lastP) ; out_K = kl endif elseif (dRhoTop >= dRhoBot) then - if (debug_this_module) write(*,*) "dRhoTop >= dRhoBot" - out_P = 1. ; out_K = kl - elseif ( (dRhoTop < 0.) .and. (dRhoBot < 0.) ) then - if (debug_this_module) write(*,*) "dRhoTop < 0. .and. dRhoBot < 0." - out_P = 1. ; out_K = kl + out_P = lastP ; out_K = kl else - if (debug_this_module) write(*,*) "Zero crossing point within layer" - out_P = interpolate_for_nondim_position(dRhoTop, Ptop, dRhoBot, Pbot) out_K = kl + out_P = interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ) endif endif - if ( (out_P < 0.) .and. (out_K < 0) ) then - call MOM_error(WARNING, "Unanticipated case in search_other_column_discontinuous") - endif - ! Check to make sure that the layer index is always increasing - if ( (out_K < lastK) .and. lastP==0. .and. out_P == 1. ) then -! out_K = lastK ; out_P = 0. - endif +! ! 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. +! 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 +! if (kl == kl_0 .and. ki == 1) then +! out_P = 0. +! out_K = kl +! elseif (dR +! out_P = 0. ! The surface is lighter than anything in layer kl +! elseif (dRhoTop >= dRhoBot) then ! Left layer is unstratified +! out_P = 1. +! else +! ! Linearly interpolate for the position between Pl(kl-1) and Pl(kl) where the density difference +! ! between right and left is zero. +! out_P = interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ) +! endif +! out_K = kl +! +! if (out_P == 0. .and. kl>kl_0) then +! if (.not. bot_connected(kl-1)) then +! out_P = 1. +! out_K = kl-1 +! endif +! endif + +! search_layer = .true. +! ! Bad values to make sure that the particular setup has been processed +! out_P = -1. ; out_K = -1 +! ! Check if everything in this layer is denser than neutral surface or if at the top of the water column +! if ((kl==kl_0 .and. ki==1)) then +! if (debug_this_module) write(*,*) "At surface" +! out_P = 0. ; out_K = kl +! search_layer = .false. +! ! Deal with the case where reconstruction is continuous +! elseif ( kl>kl_0 .and. lastK 0.)) then +! out_P = 0. ; out_K = kl +! search_layer = .false. +! endif +! endif +! +! if (search_layer) then +! if (dRhoTop > 0.) then +! if (debug_this_module) write(*,*) "dRhoTop > 0." +! if (lastK < kl) then +! out_P = 0. ; out_K = kl +! elseif (lastK == kl) then +! out_P = lastP ; out_K = lastK +! endif +! elseif ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then +! if (debug_this_module) write(*,*) "dRhoTop == 0. .and. not top_connected" +!! if ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then +! if (lastK < kl) then +! out_P = 0. ; out_K = kl +! elseif (lastK == kl) then +! out_P = lastP ; out_K = lastK +! endif +! elseif (dRhoTop >= dRhoBot) then +! if (debug_this_module) write(*,*) "dRhoTop >= dRhoBot" +! out_P = 1. ; out_K = kl +! elseif ( (dRhoTop < 0.) .and. (dRhoBot < 0.) ) then +! if (debug_this_module) write(*,*) "dRhoTop < 0. .and. dRhoBot < 0." +! out_P = 1. ; out_K = kl +! else +! if (debug_this_module) write(*,*) "Zero crossing point within layer" +! out_P = interpolate_for_nondim_position(dRhoTop, Ptop, dRhoBot, Pbot) +! out_K = kl +! endif +! endif +! +! if ( (out_P < 0.) .and. (out_K < 0) ) then +! call MOM_error(WARNING, "Unanticipated case in search_other_column_discontinuous") +! endif +! ! Check to make sure that the layer index is always increasing +! if ( (out_K < lastK) .and. lastP==0. .and. out_P == 1. ) then +!! out_K = lastK ; out_P = 0. +! endif end subroutine search_other_column_discontinuous !> Converts non-dimensional position within a layer to absolute position (for debugging) @@ -2063,9 +2149,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 10, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,3,3,3/), & ! KoL - (/2,2,2,2,2,2,3,3,3,3/), & ! KoR + (/2,2,2,3,3,3,3,3,3,3/), & ! KoR (/0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 1.0, 0.0, .75, 1.0/), & ! pL - (/0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, .25, 1.0, 1.0/), & ! pR + (/0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, .25, 1.0, 1.0/), & ! pR (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 7.5, 0.0/), & ! hEff 'Left mixed layer, right unstable mixed layer') From dc0912c1b0ec4a8911cf9e9dceec47665dff508f Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 17 Oct 2017 13:58:55 -0400 Subject: [PATCH 003/170] Logic fixed that led to negative thicknesses Fixed one piece of the logic that was leading to negative values. New code has been tested in OM4_05 and seems to give reasonable results. Now need to sanity check. Other parts of the code were cleaned up as well, but more should be done prior to a PR. --- src/tracer/MOM_neutral_diffusion.F90 | 12 ++++++------ src/tracer/MOM_neutral_diffusion_aux.F90 | 3 ++- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 5ae41e4207..0b05b7c38c 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1212,7 +1212,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, dRhoBot = 0.5 * & ( ( dRdT_l(kl_left,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left,2) - Tr(kl_right,ki_right) ) & + ( dRdS_l(kl_left,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left,2) - Sr(kl_right,ki_right) ) ) - if (.not. search_layer_l .and. kl_left>kl_left_0) then + if (lastK_left /= kl_left .and. kl_left>kl_left_0) then if (stable_l(kl_left-1) ) then ! Calculate the density difference at top of discontinuity dRhoTopm1 = 0.5 * & ( ( dRdT_l(kl_left-1,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left-1,2) - Tr(kl_right,ki_right) ) & @@ -1262,7 +1262,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, dRhoBot = 0.5 * & ( ( dRdT_r(kl_right,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,2) - Tl(kl_left,ki_left) ) & + ( dRdS_r(kl_right,2) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,2) - Sl(kl_left,ki_left) ) ) - if (kl_right>kl_right_0) then + if (lastK_right /= kl_right .and. kl_right>kl_right_0) then if(stable_r(kl_right-1)) then dRhoTopm1 = 0.5 * & ( ( dRdT_r(kl_right-1,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right-1,2) - Tl(kl_left,ki_left) ) & @@ -1417,12 +1417,12 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, if (kl > kl_0) then ! Away from top cell if (kl == lastK) then ! Searching in the same layer if (dRhoTop > 0.) then - out_P = lastP ; out_K = kl + out_P = max(0.,lastP) ; out_K = kl elseif (dRhoTop == dRhoBot) then if (top_connected(kl)) then out_P = 1. ; out_K = kl else - out_P = 0. ; out_K = kl + out_P = max(0.,lastP) ; out_K = kl endif elseif (dRhoTop >= dRhoBot) then out_P = 1. ; out_K = kl @@ -1451,10 +1451,10 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, out_P = max(0.,lastP) ; out_K = kl endif elseif (dRhoTop >= dRhoBot) then - out_P = lastP ; out_K = kl + out_P = 1. ; out_K = kl else out_K = kl - out_P = interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ) + out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) endif endif diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 61ffd8e6d4..951b01d897 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -39,7 +39,8 @@ subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) ns = 2 return endif - + first_stable = 1 + prev_stable = 1 ! First sweep down and find the first place where the column is stable do k=1,nk-1 delta_rho = ( (dRdT(k) + dRdT(k+1))*(T(k)-T(k+1)) ) + ( (dRdS(k) + dRdS(k+1))*(S(k)-S(k+1)) ) From 209b0d652f3b798f42e593d563ffb326f5c684d7 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 17 Oct 2017 17:34:26 -0400 Subject: [PATCH 004/170] Wrong condition set for refine_nondim_position --- src/tracer/MOM_neutral_diffusion_aux.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 951b01d897..e19bf071a6 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -418,7 +418,7 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re refine_nondim_position = MAX(x0,min_bound) endif - if (refine_nondim_position<0.) then + if (refine_nondim_position Date: Thu, 19 Oct 2017 17:45:33 -0400 Subject: [PATCH 005/170] Use fractions of layer thicknesses to determine hEff --- src/tracer/MOM_neutral_diffusion.F90 | 182 ++++++--------------------- 1 file changed, 40 insertions(+), 142 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 0b05b7c38c..ff7180030f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -466,9 +466,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:) ) else call find_neutral_surface_positions_discontinuous(G%ke, CS%ns(i,j)+ CS%ns(i+1,j), CS%ppoly_deg, & - CS%Pint(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & - CS%Pint(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), & + CS%Pint(i+1,j,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), & CS%dRdT_i(i+1,j,:,:), CS%dRdS_i(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%refine_position, CS%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & @@ -487,9 +487,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:) ) else call find_neutral_surface_positions_discontinuous(G%ke, CS%ns(i,j)+CS%ns(i,j+1), CS%ppoly_deg, & - CS%Pint(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & - CS%Pint(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), & + CS%Pint(i,j+1,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), & CS%dRdT_i(i,j+1,:,:), CS%dRdS_i(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%refine_position, CS%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & @@ -499,8 +499,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) endif enddo ; enddo - CS%uhEff(:,:,:) = CS%uhEff(:,:,:) / GV%H_to_pa - CS%vhEff(:,:,:) = CS%vhEff(:,:,:) / GV%H_to_pa + if (CS%continuous_reconstruction) then + CS%uhEff(:,:,:) = CS%uhEff(:,:,:) / GV%H_to_pa + CS%vhEff(:,:,:) = CS%vhEff(:,:,:) / GV%H_to_pa + endif end subroutine neutral_diffusion_calc_coeffs @@ -1083,19 +1085,22 @@ end subroutine find_neutral_surface_positions_continuous !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S -subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, & - Pres_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, PoL, PoR, KoL, KoR,& - hEff, refine_pos_in, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r, EOS, max_iter, tolerance, ref_pres) +subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, & + Pres_l, hcol_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & + PoL, PoR, KoL, KoR, hEff, & + refine_pos_in, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r, EOS, max_iter, tolerance, ref_pres) integer, intent(in) :: nk !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial used for reconstructions real, dimension(nk+1), intent(in) :: Pres_l !< Left-column interface pressure (Pa) + real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature (degC) real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity (ppt) real, dimension(nk,2), intent(in) :: dRdT_l !< Left-column, top interface dRho/dT (kg/m3/degC) real, dimension(nk,2), intent(in) :: dRdS_l !< Left-column, top interface dRho/dS (kg/m3/ppt) logical, dimension(nk), intent(in) :: stable_l !< Left-column, top interface dRho/dS (kg/m3/ppt) real, dimension(nk+1), intent(in) :: Pres_r !< Right-column interface pressure (Pa) + real, dimension(nk), intent(in) :: hcol_r !< Left-column layer thicknesses real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature (degC) real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity (ppt) real, dimension(nk,2), intent(in) :: dRdT_r !< Right-column, top interface dRho/dT (kg/m3/degC) @@ -1128,12 +1133,11 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, logical :: refine_pos ! Use rootfinding to find the true neutral surface position integer :: k, kl_left_0, kl_right_0 real :: dRho, dRhoTop, dRhoBot, dRhoTopm1, hL, hR - integer :: lastK_left, lastK_right, maxP_r - real :: lastP_left, lastP_right, maxP_l + integer :: lastK_left, lastK_right + real :: lastP_left, lastP_right real :: min_bound logical, dimension(nk) :: top_connected_l, top_connected_r logical, dimension(nk) :: bot_connected_l, bot_connected_r - logical :: search_layer_l, search_layer_r top_connected_l(:) = .false. ; top_connected_r(:) = .false. bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. @@ -1311,29 +1315,23 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, if (debug_this_module) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & KoR(k_surface), " PoR:", PoR(k_surface) ! Effective thickness - ! NOTE: This would be better expressed in terms of the layers thicknesses rather - ! than as differences of position - AJA if (k_surface>1) then + ! This is useful as a check to make sure that positions are monotonically increasing hL = absolute_position(nk,ns,Pres_l,KoL,PoL,k_surface) - absolute_position(nk,ns,Pres_l,KoL,PoL,k_surface-1) hR = absolute_position(nk,ns,Pres_r,KoR,PoR,k_surface) - absolute_position(nk,ns,Pres_r,KoR,PoR,k_surface-1) ! In the case of a layer being unstably stratified, may get a negative thickness. Set the previous position ! to the current location if ( hL<0. .or. hR<0. ) then hEff(k_surface-1) = 0. - call MOM_error(FATAL, "hL or hR is negative") - elseif ( hL + hR > 0.) then - hEff(k_surface-1) = 2. * hL * hR / ( hL + hR ) ! Harmonic mean + call MOM_error(WARNING, "hL or hR is negative") + elseif ( hL > 0. .and. hR > 0.) then + 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)) + hEff(k_surface-1) = 2. * ( (hL * hR) / ( hL + hR ) )! Harmonic mean else hEff(k_surface-1) = 0. endif - if (hEff(k_surface-1)>0.) then - if ( (KoL(k_surface-1) /= KoL(k_surface)) .or. (KoR(k_surface-1) /= KoR(k_surface)) ) then - call MOM_error(FATAL,"Neutral surfaces span multiple layers") - endif - endif - endif - enddo neutral_surfaces ! Check to make sure that neutral surfaces are truly neutral if (debug_this_module) then @@ -1346,7 +1344,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, PoL(k_surface), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), (/Pres_l(kl_left),Pres_l(kl_left+1)/), & PoR(k_surface), ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), (/Pres_r(kl_right),Pres_r(kl_right+1)/),& tolerance, ref_pres) ) then - print *, "k_surface: ", k_surface call MOM_error(WARNING,"Endpoints of neutral surfaces have different densities") endif endif @@ -1410,9 +1407,6 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, logical, dimension(:), intent(inout) :: bot_connected !< True if the top interface was pointed to real, intent( out) :: out_P !< Position within searched column integer, intent( out) :: out_K !< Layer within searched column - ! Local variables - logical :: search_layer - if (kl > kl_0) then ! Away from top cell if (kl == lastK) then ! Searching in the same layer @@ -1458,102 +1452,6 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, endif endif -! ! 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. -! 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 -! if (kl == kl_0 .and. ki == 1) then -! out_P = 0. -! out_K = kl -! elseif (dR -! out_P = 0. ! The surface is lighter than anything in layer kl -! elseif (dRhoTop >= dRhoBot) then ! Left layer is unstratified -! out_P = 1. -! else -! ! Linearly interpolate for the position between Pl(kl-1) and Pl(kl) where the density difference -! ! between right and left is zero. -! out_P = interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ) -! endif -! out_K = kl -! -! if (out_P == 0. .and. kl>kl_0) then -! if (.not. bot_connected(kl-1)) then -! out_P = 1. -! out_K = kl-1 -! endif -! endif - -! search_layer = .true. -! ! Bad values to make sure that the particular setup has been processed -! out_P = -1. ; out_K = -1 -! ! Check if everything in this layer is denser than neutral surface or if at the top of the water column -! if ((kl==kl_0 .and. ki==1)) then -! if (debug_this_module) write(*,*) "At surface" -! out_P = 0. ; out_K = kl -! search_layer = .false. -! ! Deal with the case where reconstruction is continuous -! elseif ( kl>kl_0 .and. lastK 0.)) then -! out_P = 0. ; out_K = kl -! search_layer = .false. -! endif -! endif -! -! if (search_layer) then -! if (dRhoTop > 0.) then -! if (debug_this_module) write(*,*) "dRhoTop > 0." -! if (lastK < kl) then -! out_P = 0. ; out_K = kl -! elseif (lastK == kl) then -! out_P = lastP ; out_K = lastK -! endif -! elseif ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then -! if (debug_this_module) write(*,*) "dRhoTop == 0. .and. not top_connected" -!! if ( dRhoTop == 0. .and. (.not. top_connected(kl)) ) then -! if (lastK < kl) then -! out_P = 0. ; out_K = kl -! elseif (lastK == kl) then -! out_P = lastP ; out_K = lastK -! endif -! elseif (dRhoTop >= dRhoBot) then -! if (debug_this_module) write(*,*) "dRhoTop >= dRhoBot" -! out_P = 1. ; out_K = kl -! elseif ( (dRhoTop < 0.) .and. (dRhoBot < 0.) ) then -! if (debug_this_module) write(*,*) "dRhoTop < 0. .and. dRhoBot < 0." -! out_P = 1. ; out_K = kl -! else -! if (debug_this_module) write(*,*) "Zero crossing point within layer" -! out_P = interpolate_for_nondim_position(dRhoTop, Ptop, dRhoBot, Pbot) -! out_K = kl -! endif -! endif -! -! if ( (out_P < 0.) .and. (out_K < 0) ) then -! call MOM_error(WARNING, "Unanticipated case in search_other_column_discontinuous") -! endif -! ! Check to make sure that the layer index is always increasing -! if ( (out_K < lastK) .and. lastP==0. .and. out_P == 1. ) then -!! out_K = lastK ; out_P = 0. -! endif - end subroutine search_other_column_discontinuous !> Converts non-dimensional position within a layer to absolute position (for debugging) real function absolute_position(n,ns,Pint,Karr,NParr,k_surface) @@ -2046,8 +1944,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoL @@ -2061,8 +1959,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoR @@ -2075,8 +1973,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoL (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoR @@ -2089,8 +1987,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,2,3,3,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,1,1,2,2,2,3,3/), & ! KoR @@ -2103,8 +2001,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,3,3,3,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,1,1,1,2,2,3,3/), & ! KoR @@ -2117,8 +2015,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoL (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR @@ -2131,8 +2029,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,2,3,3,3,3,3,3,3/), & ! KoL (/1,1,1,1,1,1,2,2,2,3,3,3/), & ! KoR @@ -2145,8 +2043,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 10, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,3,3,3/), & ! KoL (/2,2,2,3,3,3,3,3,3,3/), & ! KoR @@ -2160,8 +2058,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) Tir(:,1) = (/10.,14.,12./) ; TiR(:,2) = (/14.,12.,4./) call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, TiL, SiL, dRdT, dRdS, stable_l, & - Pres_r, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) + call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 8, KoL, KoR, PoL, PoR, hEff, & (/2,2,2,2,2,3,3,3/), & ! KoL (/2,2,2,3,3,3,3,3/), & ! KoR From d2a4ce129ce8508a0b01adb2f702aebfe0c909f0 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 19 Oct 2017 17:46:01 -0400 Subject: [PATCH 006/170] Use Newton's method with bracketing by bisection for refine_nondim_position --- src/tracer/MOM_neutral_diffusion_aux.F90 | 143 ++++++++++------------- 1 file changed, 64 insertions(+), 79 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index e19bf071a6..1d17c7a895 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -14,6 +14,7 @@ module MOM_neutral_diffusion_aux public calc_delta_rho public refine_nondim_position public check_neutral_positions +public kahan_sum contains @@ -195,20 +196,20 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re real :: delta_rho, d_delta_rho_dP ! Terms for the Newton iteration real :: P_int, P_min, P_ref ! Interpolated pressure - real :: delta_rho_init, delta_rho_final, x_init + real :: delta_rho_init, delta_rho_final real :: T, S, alpha, beta, alpha_avg, beta_avg - ! Newton's Method variables + ! Newton's Method with variables real :: dT_dP, dS_dP, delta_T, delta_S, delta_P real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP - ! Brent's Method variables - real :: a, b, c, d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep + real :: a, b, c, b_last + ! Extra Brent's Method variables + real :: d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep real :: P_last logical :: debug = .false. if (ref_pres>=0.) P_ref = ref_pres delta_P = P_bot-P_top refine_nondim_position = min_bound - x_init = refine_nondim_position call extract_member_EOS(EOS, form_of_EOS = form_of_EOS) do_newton = (form_of_EOS == EOS_LINEAR) .or. (form_of_EOS == EOS_TEOS10) .or. (form_of_EOS == EOS_WRIGHT) @@ -218,23 +219,18 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re do_brent = force_brent endif - ! Check to make sure that a root exists between the minimum bound and the bottom of the layer - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, refine_nondim_position, & - ref_pres, EOS, delta_rho) + ! Calculate the initial values + call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, min_bound, & + ref_pres, EOS, delta_rho, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) delta_rho_init = delta_rho -! if ( SIGN(1.,delta_rho) == SIGN(1.,drho_bot) ) then -! ! Return the position of min_bound if closer to 0 than drho_bot -! if (ABS(delta_rho) < ABS(drho_bot)) then -! refine_nondim_position = min_bound -! else -! refine_nondim_position = 1. -! endif -! do_newton = .false. ; do_brent = .false. -! endif + if ( ABS(delta_rho_init) < tolerance ) then + refine_nondim_position = min_bound + return + endif if (debug) then write (*,*) "------" - write (*,*) "Starting delta_rho: ", delta_rho + write (*,*) "Starting x0, delta_rho: ", min_bound, delta_rho endif ! For now only linear, Wright, and TEOS-10 equations of state have functions providing second derivatives and @@ -243,17 +239,12 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re refine_nondim_position = min_bound ! Set lower bound of pressure P_min = P_top*(1.-min_bound) + P_bot*(min_bound) + fa = delta_rho_init ; a = min_bound + fb = delta_rho_init ; b = min_bound + fc = drho_bot ; c = 1. ! Iterate over Newton's method for the function: x0 = x0 - delta_rho/d_delta_rho_dP do iter = 1, max_iter - ! Evaluate delta_rho(x0) - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & - refine_nondim_position, ref_pres, EOS, delta_rho, P_int, T, S, alpha_avg, & - beta_avg, delta_T, delta_S) - ! Check for convergence - if (ABS(delta_rho) <= tolerance) then - do_brent = .false. - exit - endif + P_int = P_top*(1. - b) + P_bot*b ! Evaluate total derivative of delta_rho if (ref_pres<0.) P_ref = P_int call calculate_density_second_derivs( T, S, P_ref, dbeta_dS, dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, EOS ) @@ -269,64 +260,46 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re d_delta_rho_dP = 0.5*( delta_S*(dS_dP*dbeta_dS + dT_dP*dbeta_dT + dbeta_dP) + & ( delta_T*(dS_dP*dalpha_dS + dT_dP*dalpha_dT + dalpha_dP))) + & dS_dP*beta_avg + dT_dP*alpha_avg + ! This probably won't happen, but if it does nudge the value a little for the next iteration if (d_delta_rho_dP == 0.) then - do_brent = .true. - exit + b = b + 2*EPSILON(b)*b + else + ! Newton step update + P_int = P_int - (fb / d_delta_rho_dP) + ! This line is equivalent to the next + ! refine_nondim_position = (P_top-P_int)/(P_top-P_bot) + b_last = b + b = (P_int-P_top)/delta_P + ! Test to see if it fell out of the bracketing interval. If so, take a bisection step + if (b < a .or. b > c) b = 0.5*(a + c) endif - ! Newton step update - P_last = P_int - P_int = P_int - (delta_rho / d_delta_rho_dP) - if (P_int < P_min .or. P_int > P_bot) then - if (debug) then - write (*,*) "Iteration: ", iter - write (*,*) "delta_rho, d_delta_rho_dP: ", delta_rho, d_delta_rho_dP - write (*,*) "T, T Poly Coeffs: ", T, ppoly_T - write (*,*) "S, S Poly Coeffs: ", S, ppoly_S - write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref - write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref - write (*,*) "P, dT_dP, dS_dP:", P_int, dT_dP, dS_dP - write (*,*) "dRhoTop, dRhoBot:", drho_top, drho_bot - write (*,*) "x0: ", x0 - write (*,*) "refine_nondim_position: ", refine_nondim_position - write (*,*) - endif -! call MOM_error(WARNING, "Step went out of bounds") - ! Switch to Brent's method by setting the converged flag to false - do_brent = .true. - ! Reset to first guess if already diverged -! if (ABS(delta_rho_init)tolerance if (check_neutral_positions) then - print *, "Density difference of", delta_rho + write (*,*) "Density difference of", delta_rho endif end function check_neutral_positions +!> Do a compensated sum to account for roundoff level +subroutine kahan_sum(sum, summand, c) + real, intent(inout) :: sum !< Running sum + real, intent(in ) :: summand !< Term to be added + real ,intent(inout) :: c !< Keep track of roundoff + real :: y, t + y = summand - c + t = sum + y + c = (t-sum) - y + sum = t + +end subroutine kahan_sum end module MOM_neutral_diffusion_aux From 5ef04f72893d84c1094038739b7c181ea8352087 Mon Sep 17 00:00:00 2001 From: Brandon Reichl Date: Thu, 9 Nov 2017 16:13:11 -0500 Subject: [PATCH 007/170] Add missing H_TO_M factor to SCM T/S profile initialization - The input dT/dz and dS/dz in the SCM T/S profile initializations were not divided by H_TO_M factor, thereby answers were not maintained for different H_TO_M values. - This fix has been tested to fix the issue in both cases with TS_CONFIG=SCM_CVmix_tests and TS_CONFIG=SCM_ideal_hurr --- src/user/SCM_CVmix_tests.F90 | 6 +++--- src/user/SCM_idealized_hurricane.F90 | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/user/SCM_CVmix_tests.F90 b/src/user/SCM_CVmix_tests.F90 index 3d32035a7a..be7f56ade2 100644 --- a/src/user/SCM_CVmix_tests.F90 +++ b/src/user/SCM_CVmix_tests.F90 @@ -102,17 +102,17 @@ subroutine SCM_CVmix_tests_TS_init(T, S, h, G, GV, param_file, just_read_params) do k=1,nz eta(K+1) = eta(K) - h(i,j,k)*GV%H_to_m ! Interface below layer (in m) zC = 0.5*( eta(K) + eta(K+1) ) ! Z of middle of layer (in m) - DZ = min(0., zC+UpperLayerTempMLD) + DZ = min(0., zC+UpperLayerTempMLD*GV%H_to_m) if (DZ.ge.0.0) then ! in Layer 1 T(i,j,k) = UpperLayerTemp else ! in Layer 2 - T(i,j,k) = LowerLayerTemp + LowerLayerdTdZ * DZ + T(i,j,k) = LowerLayerTemp + LowerLayerdTdZ/GV%H_to_m * DZ endif DZ = min(0., zC+UpperLayerSaltMLD) if (DZ.ge.0.0) then ! in Layer 1 S(i,j,k) = UpperLayerSalt else ! in Layer 2 - S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ * DZ + S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ/GV%H_to_m * DZ endif enddo ! k enddo ; enddo diff --git a/src/user/SCM_idealized_hurricane.F90 b/src/user/SCM_idealized_hurricane.F90 index 25c0fd3aa1..e3ef6ad272 100644 --- a/src/user/SCM_idealized_hurricane.F90 +++ b/src/user/SCM_idealized_hurricane.F90 @@ -86,7 +86,8 @@ subroutine SCM_idealized_hurricane_TS_init(T, S, h, G, GV, param_file, just_read do k=1,nz eta(K+1) = eta(K) - h(i,j,k)*GV%H_to_m ! Interface below layer (in m) zC = 0.5*( eta(K) + eta(K+1) ) ! Z of middle of layer (in m) - T(i,j,k) = SST_ref + dTdz*min(0., zC+MLD) + T(i,j,k) = SST_ref + dTdz/GV%H_to_m & + * min(0., zC+MLD*GV%H_to_m) S(i,j,k) = S_ref enddo ! k enddo ; enddo From d275e27ac22cee10e64ebf3bbfa35157fc30cbda Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 14 Nov 2017 13:52:58 -0800 Subject: [PATCH 008/170] Adds the option to balance a diffusive salt flux with a heat flux As prescribed in Griffies et al. [1998], one can enforce the condition that diffusion does not change locally referenced potential density if you balance the buoyancy flux of heat or salt with the other. This commit implements this by calculating a heat flux based on the salt flux. A new runtime parameter NDIFF_COMP_FLUX = True enables this, but is by default false. --- src/tracer/MOM_neutral_diffusion.F90 | 206 ++++++++++++++++++++++++++- src/tracer/MOM_tracer_hor_diff.F90 | 38 ++++- 2 files changed, 233 insertions(+), 11 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ff7180030f..8820a423af 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -30,6 +30,7 @@ module MOM_neutral_diffusion #include public neutral_diffusion +public neutral_diffusion_comp public neutral_diffusion_init public neutral_diffusion_diag_init public neutral_diffusion_end @@ -73,7 +74,8 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: dRdT_i ! dRho/dT (kg/m3/degC) at top edge real, allocatable, dimension(:,:,:,:) :: dRdS_i ! dRho/dS (kg/m3/ppt) at top edge integer, allocatable, dimension(:,:) :: ns ! Number of interfacs in a column - + real, allocatable, dimension(:,:,:) :: dRdT_l ! dRho/dT (kg/m3/degC) cell average + real, allocatable, dimension(:,:,:) :: dRdS_l ! dRho/dS (kg/m3/ppt) cell average logical, allocatable, dimension(:,:,:) :: stable_cell ! True if the cell is stably stratified wrt to the next cell type(diag_ctrl), pointer :: diag ! structure to regulate output @@ -200,6 +202,8 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) allocate(CS%Sint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Sint(:,:,:) = 0. allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Pint(:,:,:) = 0. allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(G))) ; CS%stable_cell(:,:,:) = .true. + allocate(CS%dRdT_l(SZI_(G),SZJ_(G),SZK_(G))) ; CS%dRdT_l(:,:,:) = 0. + allocate(CS%dRdS_l(SZI_(G),SZJ_(G),SZK_(G))) ; CS%dRdS_l(:,:,:) = 0. ! U-points allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. @@ -364,8 +368,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) ! Local variables integer :: i, j, k - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: dRdT_l !< Potential temperature (degC) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: dRdS_l !< Salinity (ppt) ! Variables used for reconstructions real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes integer :: iMethod @@ -385,6 +387,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) CS%S_i(:,:,:,:) = 0. CS%dRdT_i(:,:,:,:) = 0. CS%dRdS_i(:,:,:,:) = 0. + CS%dRdT_l(:,:,:) = 0. + CS%dRdS_l(:,:,:) = 0. CS%ns(:,:) = 0. CS%stable_cell(:,:,:) = .true. endif @@ -395,15 +399,15 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*GV%H_to_Pa if (CS%ref_pres<=0.) then P_lay = 0.5*(CS%Pint(i,j,k+1) + CS%Pint(i,j,k)) - call calculate_density_derivs(T(i,j,k), S(i,j,k), P_lay, dRdT_l(i,j,k), dRdS_l(i,j,k), EOS) + call calculate_density_derivs(T(i,j,k), S(i,j,k), P_lay, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), EOS) else - call calculate_density_derivs(T(i,j,k), S(i,j,k), CS%ref_pres, dRdT_l(i,j,k), dRdS_l(i,j,k), EOS) + call calculate_density_derivs(T(i,j,k), S(i,j,k), CS%ref_pres, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), EOS) endif enddo ; enddo ; enddo 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( G%ke, dRdT_l(i,j,:), dRdS_l(i,j,:), T(i,j,:), S(i,j,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) + call mark_unstable_cells( G%ke, CS%dRdT_l(i,j,:), CS%dRdS_l(i,j,:), T(i,j,:), S(i,j,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) enddo ; enddo endif @@ -666,6 +670,196 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) end subroutine neutral_diffusion +!> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. +subroutine neutral_diffusion_comp(G, GV, h, Coef_x, Coef_y, T, S, T_idx, S_idx, dt, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H units) + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points (m^2) + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at u-points (m^2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T !< Temperature + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: S !< Salinity + integer, intent(in) :: T_idx !< Index of temperature tracer + integer, intent(in) :: S_idx !< Index of temperature tracer + real, intent(in) :: dt !< Tracer time step * I_numitts (I_numitts in tracer_hordiff) + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer (concentration * H) + real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer (concentration * H) + real, dimension(SZI_(G),SZJ_(G),G%ke) :: T_tendency ! tendency array for diagn + real, dimension(SZI_(G),SZJ_(G)) :: T_tendency_2d ! depth integrated content tendency for diagn + real, dimension(SZIB_(G),SZJ_(G)) :: T_trans_x_2d ! depth integrated diffusive tracer x-transport diagn + real, dimension(SZI_(G),SZJB_(G)) :: T_trans_y_2d ! depth integrated diffusive tracer y-transport diagn + real, dimension(SZI_(G),SZJ_(G),G%ke) :: S_tendency ! tendency array for diagn + real, dimension(SZI_(G),SZJ_(G)) :: S_tendency_2d ! depth integrated content tendency for diagn + real, dimension(SZIB_(G),SZJ_(G)) :: S_trans_x_2d ! depth integrated diffusive tracer x-transport diagn + real, dimension(SZI_(G),SZJB_(G)) :: S_trans_y_2d ! depth integrated diffusive tracer y-transport diagn + real, dimension(G%ke) :: dS ! change in tracer concentration due to ndiffusion + real, dimension(G%ke) :: dTemp ! change in tracer concentration due to ndiffusion + real, dimension(G%ke) :: dRdT ! change in tracer concentration due to ndiffusion + real, dimension(G%ke) :: dRdS ! change in tracer concentration due to ndiffusion + integer :: i, j, k, ks, nk + real :: ppt2mks, Idt, T_convert, S_convert + + nk = GV%ke + + ! for diagnostics + if(CS%id_neutral_diff_tracer_conc_tend(T_idx) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend(T_idx) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend_2d(T_idx) > 0 .or. & + CS%id_neutral_diff_tracer_trans_x_2d(T_idx) > 0 .or. & + CS%id_neutral_diff_tracer_trans_y_2d(T_idx) > 0) then + Idt = 1.0/dt + T_tendency(:,:,:) = 0.0 + T_tendency_2d(:,:) = 0.0 + T_trans_x_2d(:,:) = 0.0 + T_trans_y_2d(:,:) = 0.0 + T_convert = CS%C_p * GV%H_to_kg_m2 + endif + if(CS%id_neutral_diff_tracer_conc_tend(S_idx) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend(S_idx) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend_2d(S_idx) > 0 .or. & + CS%id_neutral_diff_tracer_trans_x_2d(S_idx) > 0 .or. & + CS%id_neutral_diff_tracer_trans_y_2d(S_idx) > 0) then + ppt2mks = 0.001 + Idt = 1.0/dt + S_tendency(:,:,:) = 0.0 + S_tendency_2d(:,:) = 0.0 + S_trans_x_2d(:,:) = 0.0 + S_trans_y_2d(:,:) = 0.0 + S_convert = ppt2mks * GV%H_to_kg_m2 + endif + + uFlx(:,:,:) = 0. + vFlx(:,:,:) = 0. + + ! First calculate fluxes of salt + ! x-flux + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i+1,j,:), & + S(i,j,:), S(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, CS%remap_CS) + endif + enddo ; enddo + + ! y-flux + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i,j+1,:), & + S(i,j,:), S(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, CS%remap_CS) + endif + enddo ; enddo + + ! Update the tracer concentration from divergence of neutral diffusive flux components + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + + dS(:) = 0. + do ks = 1,CS%nsurf-1 ; + k = CS%uKoL(I,j,ks) + dS(k) = dS(k) + Coef_x(I,j) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dS(k) = dS(k) - Coef_x(I-1,j) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dS(k) = dS(k) + Coef_y(i,J) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dS(k) = dS(k) - Coef_y(i,J-1) * vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + S(i,j,k) = S(i,j,k) + dS(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + dTemp(k) = dS(k) * (CS%dRdS_l(i,j,k)/CS%dRdT_l(i,j,k)) + T(i,j,k) = T(i,j,k) + dTemp(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + enddo + +! Update to appropriately calculate T flux +! if(CS%id_neutral_diff_tracer_conc_tend(S_idx) > 0 .or. & +! CS%id_neutral_diff_tracer_cont_tend(S_idx) > 0 .or. & +! CS%id_neutral_diff_tracer_cont_tend_2d(S_idx) > 0 ) then +! do k = 1, GV%ke +! S_tendency(i,j,k) = dS(k) * G%IareaT(i,j) * Idt +! enddo +! endif +! if(CS%id_neutral_diff_tracer_conc_tend(T_idx) > 0 .or. & +! CS%id_neutral_diff_tracer_cont_tend(T_idx) > 0 .or. & +! CS%id_neutral_diff_tracer_cont_tend_2d(T_idx) > 0 ) then +! do k = 1, GV%ke +! T_tendency(i,j,k) = dT(k) * G%IareaT(i,j) * Idt +! enddo +! endif + + endif + enddo ; enddo + +! Need to update this so that the T fluxes are calculated correctly +! ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. +! ! Note sign corresponds to downgradient flux convention. +! if(CS%id_neutral_diff_tracer_trans_x_2d(m) > 0) then +! do j = G%jsc,G%jec ; do I = G%isc-1,G%iec +! trans_x_2d(I,j) = 0. +! if (G%mask2dCu(I,j)>0.) then +! do ks = 1,CS%nsurf-1 ; +! trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) +! enddo +! trans_x_2d(I,j) = trans_x_2d(I,j) * Idt * convert +! endif +! enddo ; enddo +! call post_data(CS%id_neutral_diff_tracer_trans_x_2d(m), trans_x_2d(:,:), CS%diag) +! endif +! +! ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. +! ! Note sign corresponds to downgradient flux convention. +! if(CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then +! do J = G%jsc-1,G%jec ; do i = G%isc,G%iec +! trans_y_2d(i,J) = 0. +! if (G%mask2dCv(i,J)>0.) then +! do ks = 1,CS%nsurf-1 ; +! trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) +! enddo +! trans_y_2d(i,J) = trans_y_2d(i,J) * Idt * convert +! endif +! enddo ; enddo +! call post_data(CS%id_neutral_diff_tracer_trans_y_2d(m), trans_y_2d(:,:), CS%diag) +! endif +! +! ! post tendency of tracer content +! if(CS%id_neutral_diff_tracer_cont_tend(m) > 0) then +! call post_data(CS%id_neutral_diff_tracer_cont_tend(m), tendency(:,:,:)*convert, CS%diag) +! endif + +! ! post depth summed tendency for tracer content +! if(CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0) then +! 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(CS%id_neutral_diff_tracer_cont_tend_2d(m), tendency_2d(:,:)*convert, 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(CS%id_neutral_diff_tracer_conc_tend(m) > 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(CS%id_neutral_diff_tracer_conc_tend(m), tendency, CS%diag) +! endif + + +end subroutine neutral_diffusion_comp + !> Returns interface scalar, Si, for a column of layer values, S. subroutine interface_scalar(nk, h, S, Si, i_method) integer, intent(in) :: nk !< Number of levels diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 6ff7bdbeac..6e08165820 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -21,7 +21,7 @@ module MOM_tracer_hor_diff use MOM_MEKE_types, only : MEKE_type 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_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion, neutral_diffusion_comp 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 @@ -52,6 +52,9 @@ module MOM_tracer_hor_diff ! limit is not violated. logical :: use_neutral_diffusion ! If true, use the neutral_diffusion module from within ! tracer_hor_diff. + logical :: ndiff_comp_flux ! If true, neutral diffusion uses Prescription B of Griffies et al. 1998, where + ! the temperature flux is calculated from the salinity flux to ensure no change in + ! locally referenced potential density due to diffusion type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() ! Control structure for neutral diffusion. type(diag_ctrl), pointer :: diag ! structure to regulate timing of diagnostic output. @@ -128,6 +131,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla real :: max_CFL ! The global maximum of the diffusive CFL number. logical :: use_VarMix, Resoln_scaled, do_online, use_Eady + integer :: S_idx, T_idx ! Indices for temperature and salinity if needed integer :: i, j, k, m, is, ie, js, je, nz, ntr, itt, num_itts real :: I_numitts ! The inverse of the number of iterations, num_itts. real :: scale ! The fraction of khdt_x or khdt_y that is applied in this @@ -349,10 +353,28 @@ 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 - do m=1,ntr ! for each tracer - call neutral_diffusion(G, GV, h, Coef_x, Coef_y, Reg%Tr(m)%t, m, I_numitts*dt, & - Reg%Tr(m)%name, CS%neutral_diffusion_CSp) - enddo ! m + if (CS%ndiff_comp_flux) then + ! Find index of T and S tracers + T_idx = -1 ; S_idx = -1 + do m=1,ntr + if (trim(Reg%tr(m)%name) == "T") T_idx = m + if (trim(Reg%tr(m)%name) == "S") S_idx = m + enddo + if ((T_idx < 0) .or. (S_idx < 0)) call MOM_error(FATAL, "Neutral diffusion: NDIFF_COMP_FLUX = .true." // & + "requires both T and S to be registered") + call neutral_diffusion_comp(G, GV, h, Coef_x, Coef_y, Reg%Tr(T_idx)%t, Reg%Tr(S_idx)%t, T_idx, S_idx, I_numitts*dt, & + CS%neutral_diffusion_CSp) + do m = 1,ntr + if ( (m == T_idx) .or. (m == S_idx) ) cycle + call neutral_diffusion(G, GV, h, Coef_x, Coef_y, Reg%Tr(m)%t, m, I_numitts*dt, & + Reg%Tr(m)%name, CS%neutral_diffusion_CSp) + enddo + else + do m=1,ntr ! for each tracer + call neutral_diffusion(G, GV, h, Coef_x, Coef_y, Reg%Tr(m)%t, m, I_numitts*dt, & + Reg%Tr(m)%name, CS%neutral_diffusion_CSp) + enddo ! m + endif enddo ! itt else ! following if not using neutral diffusion, but instead along-surface diffusion @@ -1396,6 +1418,12 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, CS, CSnd) CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, CS%neutral_diffusion_CSp) CSnd => CS%neutral_diffusion_CSp + if (CS%use_neutral_diffusion) then + call get_param(param_file, "MOM_neutral_diffusion", "NDIFF_COMP_FLUX", CS%ndiff_comp_flux, & + "If true, use Prescription B of Griffies et al. (1998) \n" // & + "to calculate the temperature flux from the salinity \n" // & + "flux to ensure that density does not change", default = .false.) + endif 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!") From f6b8a4d6480f38808f71508e936ba8ccf581d3cd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 Nov 2017 18:14:50 -0500 Subject: [PATCH 009/170] +Rescale salt fluxes with H_TO_M & alter longnames Added code to properly rescale salt fluxes when H_TO_M or H_TO_KG_M2 is not set to 1. Also changed the long names of the heat and salt fluxes to reflect their integrated names (i.e., "heat" and "salt") as opposed to concentration names ("potential temperature" and "salinity") and reflecting similar practices elsewhere in the model. All answers are bitwise identical. --- src/core/MOM.F90 | 49 ++++++++++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 22 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f907da510f..eaf13c93e1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2339,7 +2339,7 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) type(accel_diag_ptrs), intent(inout) :: ADp !< structure pointing to accelerations in momentum equation real, intent(in) :: C_p !< Heat capacity used in conversion to watts - real :: conv2watt + real :: conv2watt, conv2salt character(len=48) :: thickness_units, flux_units, S_flux_units type(diag_ctrl), pointer :: diag integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz @@ -2350,8 +2350,10 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) - S_flux_units = get_tr_flux_units(GV, "psu") + S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? conv2watt = GV%H_to_kg_m2 * C_p + conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001 and remove the following line? + if (.not.GV%Boussinesq) conv2salt = GV%H_to_kg_m2 !Initialize the diagnostics mask arrays. !This has to be done after MOM_initialize_state call. @@ -2434,8 +2436,8 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) endif if (CS%use_temperature .and. CS%use_frazil) then - CS%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & - 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & + CS%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & + 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') endif @@ -2449,17 +2451,17 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) ! lateral heat advective and diffusive fluxes - CS%id_Tadx = register_diag_field('ocean_model', 'T_adx', diag%axesCuL, Time, & - 'Advective (by residual mean) Zonal Flux of Potential Temperature', 'W m-2', & + CS%id_Tadx = register_diag_field('ocean_model', 'T_adx', diag%axesCuL, Time, & + 'Advective (by residual mean) Zonal Flux of Heat', 'W m-2', & v_extensive = .true., conversion = conv2watt) - CS%id_Tady = register_diag_field('ocean_model', 'T_ady', diag%axesCvL, Time, & - 'Advective (by residual mean) Meridional Flux of Potential Temperature', 'W m-2', & + CS%id_Tady = register_diag_field('ocean_model', 'T_ady', diag%axesCvL, Time, & + 'Advective (by residual mean) Meridional Flux of Heat', 'W m-2', & v_extensive = .true., conversion = conv2watt) - CS%id_Tdiffx = register_diag_field('ocean_model', 'T_diffx', diag%axesCuL, Time, & - 'Diffusive Zonal Flux of Potential Temperature', 'W m-2', & + CS%id_Tdiffx = register_diag_field('ocean_model', 'T_diffx', diag%axesCuL, Time, & + 'Diffusive Zonal Flux of Heat', 'W m-2', & v_extensive = .true., conversion = conv2watt) CS%id_Tdiffy = register_diag_field('ocean_model', 'T_diffy', diag%axesCvL, Time, & - 'Diffusive Meridional Flux of Potential Temperature', 'W m-2', & + 'Diffusive Meridional Flux of Heat', 'W m-2', & v_extensive = .true., conversion = conv2watt) if (CS%id_Tadx > 0) call safe_alloc_ptr(CS%T_adx,IsdB,IedB,jsd,jed,nz) if (CS%id_Tady > 0) call safe_alloc_ptr(CS%T_ady,isd,ied,JsdB,JedB,nz) @@ -2469,11 +2471,14 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) ! lateral salt advective and diffusive fluxes CS%id_Sadx = register_diag_field('ocean_model', 'S_adx', diag%axesCuL, Time, & - 'Advective (by residual mean) Zonal Flux of Salinity', S_flux_units, v_extensive = .true.) + 'Advective (by residual mean) Zonal Flux of Salt', S_flux_units, & + v_extensive = .true., conversion = conv2salt) CS%id_Sady = register_diag_field('ocean_model', 'S_ady', diag%axesCvL, Time, & - 'Advective (by residual mean) Meridional Flux of Salinity', S_flux_units, v_extensive = .true.) + 'Advective (by residual mean) Meridional Flux of Salt', S_flux_units, & + v_extensive = .true., conversion = conv2salt) CS%id_Sdiffx = register_diag_field('ocean_model', 'S_diffx', diag%axesCuL, Time, & - 'Diffusive Zonal Flux of Salinity', S_flux_units, v_extensive = .true.) + 'Diffusive Zonal Flux of Salt', S_flux_units, & + v_extensive = .true., conversion = conv2salt) CS%id_Sdiffy = register_diag_field('ocean_model', 'S_diffy', diag%axesCvL, Time, & 'Diffusive Meridional Flux of Salinity', S_flux_units, v_extensive = .true.) if (CS%id_Sadx > 0) call safe_alloc_ptr(CS%S_adx,IsdB,IedB,jsd,jed,nz) @@ -2484,13 +2489,13 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) ! vertically integrated lateral heat advective and diffusive fluxes CS%id_Tadx_2d = register_diag_field('ocean_model', 'T_adx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Advective Zonal Flux of Potential Temperature', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Advective Zonal Flux of Heat', 'W m-2', conversion = conv2watt) CS%id_Tady_2d = register_diag_field('ocean_model', 'T_ady_2d', diag%axesCv1, Time, & - 'Vertically Integrated Advective Meridional Flux of Potential Temperature', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Advective Meridional Flux of Heat', 'W m-2', conversion = conv2watt) CS%id_Tdiffx_2d = register_diag_field('ocean_model', 'T_diffx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Diffusive Zonal Flux of Potential Temperature', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Diffusive Zonal Flux of Heat', 'W m-2', conversion = conv2watt) CS%id_Tdiffy_2d = register_diag_field('ocean_model', 'T_diffy_2d', diag%axesCv1, Time, & - 'Vertically Integrated Diffusive Meridional Flux of Potential Temperature', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Diffusive Meridional Flux of Heat', 'W m-2', conversion = conv2watt) if (CS%id_Tadx_2d > 0) call safe_alloc_ptr(CS%T_adx_2d,IsdB,IedB,jsd,jed) if (CS%id_Tady_2d > 0) call safe_alloc_ptr(CS%T_ady_2d,isd,ied,JsdB,JedB) if (CS%id_Tdiffx_2d > 0) call safe_alloc_ptr(CS%T_diffx_2d,IsdB,IedB,jsd,jed) @@ -2498,13 +2503,13 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) ! vertically integrated lateral salt advective and diffusive fluxes CS%id_Sadx_2d = register_diag_field('ocean_model', 'S_adx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Advective Zonal Flux of Salinity', S_flux_units) + 'Vertically Integrated Advective Zonal Flux of Salt', S_flux_units, conversion = conv2salt) CS%id_Sady_2d = register_diag_field('ocean_model', 'S_ady_2d', diag%axesCv1, Time, & - 'Vertically Integrated Advective Meridional Flux of Salinity', S_flux_units) + 'Vertically Integrated Advective Meridional Flux of Salt', S_flux_units, conversion = conv2salt) CS%id_Sdiffx_2d = register_diag_field('ocean_model', 'S_diffx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Diffusive Zonal Flux of Salinity', S_flux_units) + 'Vertically Integrated Diffusive Zonal Flux of Salt', S_flux_units, conversion = conv2salt) CS%id_Sdiffy_2d = register_diag_field('ocean_model', 'S_diffy_2d', diag%axesCv1, Time, & - 'Vertically Integrated Diffusive Meridional Flux of Salinity', S_flux_units) + 'Vertically Integrated Diffusive Meridional Flux of Salt', S_flux_units, conversion = conv2salt) if (CS%id_Sadx_2d > 0) call safe_alloc_ptr(CS%S_adx_2d,IsdB,IedB,jsd,jed) if (CS%id_Sady_2d > 0) call safe_alloc_ptr(CS%S_ady_2d,isd,ied,JsdB,JedB) if (CS%id_Sdiffx_2d > 0) call safe_alloc_ptr(CS%S_diffx_2d,IsdB,IedB,jsd,jed) From c556d774438fc1325e3cf274a03c98d4fa745fb9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Nov 2017 09:16:03 -0500 Subject: [PATCH 010/170] +Move register_cell_measure into MOM_diag_mediator Moved the subroutine register_cell_measure out of MOM.F90 and into MOM_diag_mediator. Also folded the subtroutine write_parameter_fields into write_static_fields, as there was no particularly good reason for these to be separate calls. All answers are bitwise identical. --- src/core/MOM.F90 | 45 ++++++++--------------------- src/framework/MOM_diag_mediator.F90 | 17 ++++++++++- 2 files changed, 28 insertions(+), 34 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index eaf13c93e1..1229e10d6c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -33,7 +33,7 @@ module MOM use MOM_diag_mediator, only : diag_mediator_init, enable_averaging use MOM_diag_mediator, only : diag_mediator_infrastructure_init use MOM_diag_mediator, only : diag_register_area_ids -use MOM_diag_mediator, only : diag_associate_volume_cell_measure +use MOM_diag_mediator, only : register_cell_measure use MOM_diag_mediator, only : diag_set_state_ptrs, diag_update_remap_grids use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_static_field @@ -2108,8 +2108,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call set_masks_for_axes(G, diag) ! Diagnose static fields AND associate areas/volumes with axes - call write_static_fields(G, CS%diag) - call write_parameter_fields(G, CS) + call write_static_fields(G, GV, CS%tv, CS%diag) call callTree_waypoint("static fields written (initialize_MOM)") ! Register the volume cell measure (must be one of first diagnostics) @@ -3166,26 +3165,14 @@ subroutine post_surface_diagnostics(CS, G, diag, sfc_state) end subroutine post_surface_diagnostics -!> Sets a handle inside diagnostics mediator to associate 3d cell measures -subroutine register_cell_measure(G, diag, Time) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(diag_ctrl), target, intent(inout) :: diag !< Regulates diagnostic output - type(time_type), intent(in) :: Time !< Model time - ! Local variables - integer :: id - id = register_diag_field('ocean_model', 'volcello', diag%axesTL, & - Time, 'Ocean grid-cell volume', 'm3', & - standard_name='ocean_volume', v_extensive=.true., & - x_cell_method='sum', y_cell_method='sum') - call diag_associate_volume_cell_measure(diag, id) - -end subroutine register_cell_measure !> Offers the static fields in the ocean grid type !! for output via the diag_manager. -subroutine write_static_fields(G, diag) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output +subroutine write_static_fields(G, GV, tv, diag) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output ! Local variables real :: tmp_h(SZI_(G),SZJ_(G)) integer :: id, i, j @@ -3325,28 +3312,20 @@ subroutine write_static_fields(G, diag) call post_data(id, tmp_h, diag, .true.) endif -end subroutine write_static_fields - -subroutine write_parameter_fields(G, CS) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(MOM_control_struct),pointer :: CS !< pointer set in this routine to MOM control structure - ! Local variables - integer :: id - - id = register_static_field('ocean_model','Rho_0', CS%diag%axesNull, & + id = register_static_field('ocean_model','Rho_0', diag%axesNull, & 'mean ocean density used with the Boussinesq approximation', & 'kg m-3', cmor_field_name='rhozero', & cmor_standard_name='reference_sea_water_density_for_boussinesq_approximation', & cmor_long_name='reference sea water density for boussinesq approximation') - if (id > 0) call post_data(id, CS%GV%Rho0, CS%diag, .true.) + if (id > 0) call post_data(id, GV%Rho0, diag, .true.) - id = register_static_field('ocean_model','C_p', CS%diag%axesNull, & + id = register_static_field('ocean_model','C_p', diag%axesNull, & 'heat capacity of sea water', 'J kg-1 K-1', cmor_field_name='cpocean', & cmor_standard_name='specific_heat_capacity_of_sea_water', & cmor_long_name='specific_heat_capacity_of_sea_water') - if (id > 0) call post_data(id, CS%tv%C_p, CS%diag, .true.) + if (id > 0) call post_data(id, tv%C_p, diag, .true.) -end subroutine write_parameter_fields +end subroutine write_static_fields !> Set the fields that are needed for bitwise identical restarting !! the time stepping scheme. In addition to those specified here diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index ee4aa06270..6cc2674288 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -59,7 +59,7 @@ module MOM_diag_mediator public register_scalar_field public define_axes_group, diag_masks_set public diag_register_area_ids -public diag_associate_volume_cell_measure +public register_cell_measure, diag_associate_volume_cell_measure public diag_get_volume_cell_measure_dm_id public diag_set_state_ptrs, diag_update_remap_grids @@ -504,6 +504,21 @@ subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q) endif end subroutine diag_register_area_ids +!> Sets a handle inside diagnostics mediator to associate 3d cell measures +subroutine register_cell_measure(G, diag, Time) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(diag_ctrl), target, intent(inout) :: diag !< Regulates diagnostic output + type(time_type), intent(in) :: Time !< Model time + ! Local variables + integer :: id + id = register_diag_field('ocean_model', 'volcello', diag%axesTL, & + Time, 'Ocean grid-cell volume', 'm3', & + standard_name='ocean_volume', v_extensive=.true., & + x_cell_method='sum', y_cell_method='sum') + call diag_associate_volume_cell_measure(diag, id) + +end subroutine register_cell_measure + !> Attaches the id of cell volumes to axes groups for use with cell_measures subroutine diag_associate_volume_cell_measure(diag_cs, id_h_volume) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure From 7b6d08f89c6c02ac0c2df50356764cb91b69ef3a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Nov 2017 16:28:58 -0500 Subject: [PATCH 011/170] +Added debuggingParam arguments to get_param, etc. Added an optional argument to the various get_param, log_param, and doc_param subroutines to indicate that a variable should be logged in a parameter_doc.debugging file, which is intended to be used for any parameters whose setting should not alter solutions. All answers are bitwise identical. --- src/framework/MOM_document.F90 | 111 +++++++++++++++++++++++------- src/framework/MOM_file_parser.F90 | 64 ++++++++++------- 2 files changed, 125 insertions(+), 50 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 484fc2a8a7..d2317178f8 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -32,12 +32,14 @@ module MOM_document integer :: unitAll = -1 ! The open unit number for docFileBase + .all. integer :: unitShort = -1 ! The open unit number for docFileBase + .short. integer :: unitLayout = -1 ! The open unit number for docFileBase + .layout. + integer :: unitDebugging = -1 ! The open unit number for docFileBase + .debugging. logical :: filesAreOpen = .false. ! True if any files were successfully opened. character(len=mLen) :: docFileBase = '' ! The basename of the files where run-time ! parameters, settings and defaults are documented. logical :: complete = .true. ! If true, document all parameters. logical :: minimal = .true. ! If true, document non-default parameters. logical :: layout = .true. ! If true, document layout parameters. + logical :: debugging = .true. ! If true, document debugging parameters. logical :: defineSyntax = .false. ! If true, use #def syntax instead of a=b syntax logical :: warnOnConflicts = .false. ! Cause a WARNING error if defaults differ. integer :: commentColumn = 32 ! Number of spaces before the comment marker. @@ -78,12 +80,14 @@ subroutine doc_param_none(doc, varname, desc, units) endif end subroutine doc_param_none -subroutine doc_param_logical(doc, varname, desc, units, val, default, layoutParam) +subroutine doc_param_logical(doc, varname, desc, units, val, default, & + layoutParam, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units logical, intent(in) :: val logical, optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for logicals. character(len=mLen) :: mesg logical :: equalsDefault @@ -109,16 +113,19 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, layoutPara endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, layoutParam=layoutParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) endif end subroutine doc_param_logical -subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, layoutParam) +subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & + layoutParam, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units logical, intent(in) :: vals(:) logical, optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for arrays of logicals. integer :: i character(len=mLen) :: mesg @@ -152,16 +159,19 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, lay endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, layoutParam=layoutParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) endif end subroutine doc_param_logical_array -subroutine doc_param_int(doc, varname, desc, units, val, default, layoutParam) +subroutine doc_param_int(doc, varname, desc, units, val, default, & + layoutParam, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units integer, intent(in) :: val integer, optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for integers. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -181,16 +191,19 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, layoutParam) endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, layoutParam=layoutParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) endif end subroutine doc_param_int -subroutine doc_param_int_array(doc, varname, desc, units, vals, default, layoutParam) +subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & + layoutParam, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units integer, intent(in) :: vals(:) integer, optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for arrays of integers. integer :: i character(len=mLen) :: mesg @@ -216,16 +229,18 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, layoutP endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, layoutParam=layoutParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) endif end subroutine doc_param_int_array -subroutine doc_param_real(doc, varname, desc, units, val, default) +subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units real, intent(in) :: val real, optional, intent(in) :: default + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for reals. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -245,15 +260,17 @@ subroutine doc_param_real(doc, varname, desc, units, val, default) endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + debuggingParam=debuggingParam) endif end subroutine doc_param_real -subroutine doc_param_real_array(doc, varname, desc, units, vals, default) +subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units real, intent(in) :: vals(:) real, optional, intent(in) :: default + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for arrays of reals. integer :: i character(len=mLen) :: mesg @@ -276,17 +293,20 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default) endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + debuggingParam=debuggingParam) endif end subroutine doc_param_real_array -subroutine doc_param_char(doc, varname, desc, units, val, default, layoutParam) +subroutine doc_param_char(doc, varname, desc, units, val, default, & + layoutParam, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units character(len=*), intent(in) :: val character(len=*), optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for character strings. character(len=mLen) :: mesg logical :: equalsDefault @@ -304,7 +324,8 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, layoutParam) endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, layoutParam=layoutParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) endif end subroutine doc_param_char @@ -356,12 +377,14 @@ subroutine doc_closeBlock(doc, blockName) endif end subroutine doc_closeBlock -subroutine doc_param_time(doc, varname, desc, units, val, default, layoutParam) +subroutine doc_param_time(doc, varname, desc, units, val, default, & + layoutParam, debuggingParam) type(doc_type), pointer :: doc character(len=*), intent(in) :: varname, desc, units type(time_type), intent(in) :: val type(time_type), optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine handles parameter documentation for time-type variables. ! ### This needs to be written properly! integer :: numspc @@ -378,30 +401,34 @@ subroutine doc_param_time(doc, varname, desc, units, val, default, layoutParam) if (len_trim(units) > 0) mesg = trim(mesg)//" ["//trim(units)//"]" if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, layoutParam=layoutParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & + layoutParam=layoutParam, debuggingParam=debuggingParam) endif end subroutine doc_param_time -subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, layoutParam) +subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & + layoutParam, debuggingParam) type(doc_type), intent(in) :: doc character(len=*), intent(in) :: vmesg, desc logical, optional, intent(in) :: valueWasDefault integer, optional, intent(in) :: indent logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam character(len=mLen) :: mesg integer :: start_ind = 1, end_ind, indnt, tab, len_tab, len_nl - logical :: all, short, layout + logical :: all, short, layout, debug - layout = .false. - if (present(layoutParam)) layout = layoutParam - all = doc%complete .and. (doc%unitAll > 0) .and. .not. layout - short = doc%minimal .and. (doc%unitShort > 0) .and. .not. layout + layout = .false. ; if (present(layoutParam)) layout = layoutParam + debug = .false. ; if (present(debuggingParam)) debug = debuggingParam + all = doc%complete .and. (doc%unitAll > 0) .and. .not. (layout .or. debug) + short = doc%minimal .and. (doc%unitShort > 0) .and. .not. (layout .or. debug) if (present(valueWasDefault)) short = short .and. (.not. valueWasDefault) if (all) write(doc%unitAll, '(a)') trim(vmesg) if (short) write(doc%unitShort, '(a)') trim(vmesg) if (layout) write(doc%unitLayout, '(a)') trim(vmesg) + if (debug) write(doc%unitDebugging, '(a)') trim(vmesg) if (len_trim(desc) == 0) return @@ -426,6 +453,7 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, layout if (all) write(doc%unitAll, '(a)') trim(mesg) if (short) write(doc%unitShort, '(a)') trim(mesg) if (layout) write(doc%unitLayout, '(a)') trim(mesg) + if (debug) write(doc%unitDebugging, '(a)') trim(mesg) else mesg = repeat(" ",indnt)//"! "//trim(desc(start_ind:)) do ; tab = index(mesg, "\t") @@ -435,6 +463,7 @@ subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, layout if (all) write(doc%unitAll, '(a)') trim(mesg) if (short) write(doc%unitShort, '(a)') trim(mesg) if (layout) write(doc%unitLayout, '(a)') trim(mesg) + if (debug) write(doc%unitDebugging, '(a)') trim(mesg) exit endif @@ -632,10 +661,10 @@ end subroutine doc_function ! ---------------------------------------------------------------------- -subroutine doc_init(docFileBase, doc, minimal, complete) +subroutine doc_init(docFileBase, doc, minimal, complete, layout, debugging) character(len=*), intent(in) :: docFileBase type(doc_type), pointer :: doc - logical, optional, intent(in) :: minimal, complete + logical, optional, intent(in) :: minimal, complete, layout, debugging ! Arguments: docFileBase - The name of the doc file. ! (inout) doc - The doc_type to populate. @@ -645,7 +674,10 @@ subroutine doc_init(docFileBase, doc, minimal, complete) doc%docFileBase = docFileBase if (present(minimal)) doc%minimal = minimal - if (present(minimal)) doc%complete = complete + if (present(complete)) doc%complete = complete + if (present(layout)) doc%layout = layout + if (present(debugging)) doc%debugging = debugging + end subroutine doc_init subroutine open_doc_file(doc) @@ -666,7 +698,8 @@ subroutine open_doc_file(doc) open(doc%unitAll, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='REPLACE', iostat=ios) write(doc%unitAll, '(a)') & - '! This file was written by the model and records all non-layout parameters used at run-time.' + '! This file was written by the model and records all non-layout '//& + 'or debugging parameters used at run-time.' else ! This file is being reopened, and should be appended. open(doc%unitAll, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='OLD', position='APPEND', iostat=ios) @@ -720,6 +753,27 @@ subroutine open_doc_file(doc) doc%filesAreOpen = .true. endif + if ((len_trim(doc%docFileBase) > 0) .and. doc%debugging .and. (doc%unitDebugging<0)) then + new_file = .true. ; if (doc%unitDebugging /= -1) new_file = .false. + doc%unitDebugging = find_unused_unit_number() + + write(fileName(1:240),'(a)') trim(doc%docFileBase)//'.debugging' + if (new_file) then + open(doc%unitDebugging, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + write(doc%unitDebugging, '(a)') & + '! This file was written by the model and records the debugging parameters used at run-time.' + else ! This file is being reopened, and should be appended. + open(doc%unitDebugging, file=trim(fileName), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(doc%unitDebugging, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open doc file "//trim(fileName)//".") + endif + doc%filesAreOpen = .true. + endif + end subroutine open_doc_file function find_unused_unit_number() @@ -756,6 +810,11 @@ subroutine doc_end(doc) doc%unitLayout = -2 endif + if (doc%unitDebugging > 0) then + close(doc%unitDebugging) + doc%unitDebugging = -2 + endif + doc%filesAreOpen = .false. this => doc%chain_msg diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 37879541a9..436008101f 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -239,7 +239,8 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) CS%complete_doc = .false. CS%minimal_doc = .false. endif - call doc_init(doc_path, CS%doc, CS%minimal_doc, CS%complete_doc) + call doc_init(doc_path, CS%doc, minimal=CS%minimal_doc, complete=CS%complete_doc, & + layout=CS%complete_doc, debugging=CS%complete_doc) end subroutine open_param_file @@ -1237,7 +1238,7 @@ subroutine log_version_plain(modulename, version) end subroutine log_version_plain subroutine log_param_int(CS, modulename, varname, value, desc, units, & - default, layoutParam) + default, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1245,6 +1246,7 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & character(len=*), optional, intent(in) :: desc, units integer, optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of an integer parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1258,12 +1260,12 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam) + layoutParam=layoutParam, debuggingParam=debuggingParam) end subroutine log_param_int subroutine log_param_int_array(CS, modulename, varname, value, desc, & - units, default, layoutParam) + units, default, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1271,6 +1273,7 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & character(len=*), optional, intent(in) :: desc, units integer, optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of an integer parameter to a log file, ! along with its name and the module it came from. character(len=1320) :: mesg @@ -1285,18 +1288,19 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam) + layoutParam=layoutParam, debuggingParam=debuggingParam) end subroutine log_param_int_array subroutine log_param_real(CS, modulename, varname, value, desc, units, & - default) + default, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname real, intent(in) :: value character(len=*), optional, intent(in) :: desc, units real, optional, intent(in) :: default + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1310,7 +1314,8 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & - call doc_param(CS%doc, varname, desc, myunits, value, default) + call doc_param(CS%doc, varname, desc, myunits, value, default, & + debuggingParam=debuggingParam) end subroutine log_param_real @@ -1344,7 +1349,7 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & end subroutine log_param_real_array subroutine log_param_logical(CS, modulename, varname, value, desc, & - units, default, layoutParam) + units, default, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1352,6 +1357,7 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & character(len=*), optional, intent(in) :: desc, units logical, optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of a logical parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1369,12 +1375,12 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam) + layoutParam=layoutParam, debuggingParam=debuggingParam) end subroutine log_param_logical subroutine log_param_char(CS, modulename, varname, value, desc, units, & - default, layoutParam) + default, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1382,6 +1388,7 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & character(len=*), optional, intent(in) :: desc, units character(len=*), optional, intent(in) :: default logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of a character string parameter to a log ! file, along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1396,14 +1403,14 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam) + layoutParam=layoutParam, debuggingParam=debuggingParam) end subroutine log_param_char !> This subroutine writes the value of a time-type parameter to a log file, !! along with its name and the module it came from. subroutine log_param_time(CS, modulename, varname, value, desc, units, & - default, timeunit, layoutParam, log_date) + default, timeunit, layoutParam, debuggingParam, log_date) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1413,6 +1420,7 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & real, optional, intent(in) :: timeunit logical, optional, intent(in) :: log_date !< If true, log the time_type in date format. logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam real :: real_time, real_default logical :: use_timeunit, date_format @@ -1446,10 +1454,11 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & if (present(default)) then default_string = convert_date_to_string(default) call doc_param(CS%doc, varname, desc, myunits, date_string, & - default=default_string, layoutParam=layoutParam) + default=default_string, layoutParam=layoutParam, & + debuggingParam=debuggingParam) else call doc_param(CS%doc, varname, desc, myunits, date_string, & - layoutParam=layoutParam) + layoutParam=layoutParam, debuggingParam=debuggingParam) endif elseif (use_timeunit) then if (present(units)) then @@ -1512,7 +1521,7 @@ end function convert_date_to_string subroutine get_param_int(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam) + static_value, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1522,6 +1531,7 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: fail_if_missing logical, optional, intent(in) :: do_not_read, do_not_log logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1537,14 +1547,14 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & if (do_log) then call log_param_int(CS, modulename, varname, value, desc, units, & - default, layoutParam) + default, layoutParam, debuggingParam) endif end subroutine get_param_int subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam) + static_value, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1554,6 +1564,7 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: fail_if_missing logical, optional, intent(in) :: do_not_read, do_not_log logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1569,7 +1580,7 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & if (do_log) then call log_param_int_array(CS, modulename, varname, value, desc, & - units, default, layoutParam) + units, default, layoutParam, debuggingParam) endif end subroutine get_param_int_array @@ -1636,7 +1647,7 @@ end subroutine get_param_real_array subroutine get_param_char(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam) + static_value, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1646,6 +1657,7 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: fail_if_missing logical, optional, intent(in) :: do_not_read, do_not_log logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1661,7 +1673,7 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & if (do_log) then call log_param_char(CS, modulename, varname, value, desc, units, & - default, layoutParam) + default, layoutParam, debuggingParam) endif end subroutine get_param_char @@ -1708,7 +1720,7 @@ end subroutine get_param_char_array subroutine get_param_logical(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam) + static_value, layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1718,6 +1730,7 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: fail_if_missing logical, optional, intent(in) :: do_not_read, do_not_log logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1733,14 +1746,15 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & if (do_log) then call log_param_logical(CS, modulename, varname, value, desc, & - units, default, layoutParam) + units, default, layoutParam, debuggingParam) endif end subroutine get_param_logical subroutine get_param_time(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - timeunit, static_value, layoutParam, log_as_date) + timeunit, static_value, layoutParam, debuggingParam, & + log_as_date) type(param_file_type), intent(in) :: CS character(len=*), intent(in) :: modulename character(len=*), intent(in) :: varname @@ -1751,6 +1765,7 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: do_not_read, do_not_log real, optional, intent(in) :: timeunit logical, optional, intent(in) :: layoutParam + logical, optional, intent(in) :: debuggingParam logical, optional, intent(in) :: log_as_date ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. @@ -1769,7 +1784,8 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & if (do_log) then if (present(log_as_date)) log_date = log_as_date call log_param_time(CS, modulename, varname, value, desc, units, default, & - timeunit, layoutParam=layoutParam, log_date=log_date) + timeunit, layoutParam=layoutParam, & + debuggingParam=debuggingParam, log_date=log_date) endif end subroutine get_param_time From 1b9e1afd6b8cdf904aa3e27e38ea08c1f4e4e351 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Nov 2017 16:29:57 -0500 Subject: [PATCH 012/170] Changed the long-name of S_diffy diagnostic Change the long name of S_diffy to 'Diffusive Meridional Flux of Salt' from 'Diffusive Meridional Flux of Salinity'. This was accidentally omitted from commit Hallberg-NOAA/MOM6@f6b8a4d6480f38808f71508e936ba8ccf581d3cd. All answers are bitwise identical. --- 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 e18a3ffb8b..c618a2c353 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2479,7 +2479,7 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) 'Diffusive Zonal Flux of Salt', S_flux_units, & v_extensive = .true., conversion = conv2salt) CS%id_Sdiffy = register_diag_field('ocean_model', 'S_diffy', diag%axesCvL, Time, & - 'Diffusive Meridional Flux of Salinity', S_flux_units, v_extensive = .true.) + 'Diffusive Meridional Flux of Salt', S_flux_units, v_extensive = .true.) if (CS%id_Sadx > 0) call safe_alloc_ptr(CS%S_adx,IsdB,IedB,jsd,jed,nz) if (CS%id_Sady > 0) call safe_alloc_ptr(CS%S_ady,isd,ied,JsdB,JedB,nz) if (CS%id_Sdiffx > 0) call safe_alloc_ptr(CS%S_diffx,IsdB,IedB,jsd,jed,nz) From a7b8baea8d6692b7c157162ebb302ba0d0a01612 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Nov 2017 16:30:22 -0500 Subject: [PATCH 013/170] +Added run-time argument H_RESCALE_POWER Added a new run-time argument for the power of 2 that should be used to rescale the internal representation of thickness. This is intended primarily for use in debugging, and if the code is working properly it should not change answers. This addition changes the entries to the MOM_parameter_doc.debugging file, but (by default at least) all answers are bitwise identical. --- src/core/MOM_verticalGrid.F90 | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index c11d63a890..a57bd1f61f 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -72,7 +72,8 @@ subroutine verticalGridInit( param_file, GV ) type(verticalGrid_type), pointer :: GV ! The container for vertical grid data ! This include declares and sets the variable "version". #include "version_variable.h" - integer :: nk + integer :: nk, H_power + real :: rescale_factor character(len=16) :: mdl = 'MOM_verticalGrid' if (associated(GV)) call MOM_error(FATAL, & @@ -96,15 +97,25 @@ subroutine verticalGridInit( param_file, GV ) call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_z, & "The minumum layer thickness, usually one-Angstrom.", & units="m", default=1.0e-10) + call get_param(param_file, mdl, "H_RESCALE_POWER", H_power, & + "An integer power of 2 that is used to rescale the model's \n"//& + "intenal units of thickness. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + if (abs(H_power) > 300) call MOM_error(FATAL, "verticalGridInit: "//& + "H_RESCALE_POWER is outside of the valid range of -300 to 300.") + rescale_factor = 1.0 + if (H_power /= 0) rescale_factor = 2.0**H_power if (.not.GV%Boussinesq) then call get_param(param_file, mdl, "H_TO_KG_M2", GV%H_to_kg_m2,& "A constant that translates thicknesses from the model's \n"//& "internal units of thickness to kg m-2.", units="kg m-2 H-1", & default=1.0) + GV%H_to_kg_m2 = GV%H_to_kg_m2 * rescale_factor else call get_param(param_file, mdl, "H_TO_M", GV%H_to_m, & "A constant that translates the model's internal \n"//& "units of thickness into m.", units="m H-1", default=1.0) + GV%H_to_m = GV%H_to_m * rescale_factor endif #ifdef STATIC_MEMORY_ ! Here NK_ is a macro, while nk is a variable. @@ -135,7 +146,9 @@ subroutine verticalGridInit( param_file, GV ) GV%H_to_Pa = GV%g_Earth * GV%H_to_kg_m2 ! Log derivative values. - call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H) + call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*rescale_factor) + call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H) + call log_param(param_file, mdl, "THICKNESS to M rescaled by 2^n", GV%H_to_m) ALLOC_( GV%sInterface(nk+1) ) ALLOC_( GV%sLayer(nk) ) From 77f7446c824f376967c12902b88fa703a4f0c3ec Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 20 Nov 2017 14:51:48 -0900 Subject: [PATCH 014/170] Fix to stencil=2 trouble. - We need to exchange bt_rem_u and bt_rem_v even without wide halos. - Some other cleanup of the logic around OBCs in MOM_barotropic. - Changed the definition of on_pe in MOM_open_boundary. - Still not out of the woods on rotated_seamount. --- src/core/MOM_barotropic.F90 | 28 +++++++++++++++------------- src/core/MOM_open_boundary.F90 | 12 ++++++------ 2 files changed, 21 insertions(+), 19 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index c2486c2cdf..b8e91cac37 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -88,7 +88,7 @@ module MOM_barotropic use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE +use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, open_boundary_query use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS @@ -676,12 +676,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & (CS%Nonlin_cont_update_period > 0)) stencil = 2 - num_cycles = 1 - if (CS%use_wide_halos) & - num_cycles = min((is-CS%isdw) / stencil, (js-CS%jsdw) / stencil) - isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil - jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil - do_ave = query_averaging_enabled(CS%diag) find_etaav = present(etaav) find_PF = (do_ave .and. ((CS%id_PFu_bt > 0) .or. (CS%id_PFv_bt > 0))) @@ -707,17 +701,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & if (present(OBC)) then ; if (associated(OBC)) then CS%BT_OBC%apply_u_OBCs = OBC%open_u_BCs_exist_globally .or. OBC%specified_u_BCs_exist_globally CS%BT_OBC%apply_v_OBCs = OBC%open_v_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally - apply_OBC_flather = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally - apply_OBC_open = OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally - apply_OBCs = OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. & + apply_OBC_flather = open_boundary_query(OBC, apply_Flather_OBC=.true.) + apply_OBC_open = open_boundary_query(OBC, apply_open_OBC=.true.) + apply_OBCs = open_boundary_query(OBC, apply_specified_OBC=.true.) .or. & apply_OBC_flather .or. apply_OBC_open - if (.not.apply_OBC_flather .and. OBC%oblique_BCs_exist_globally) stencil = 2 +! if (.not.apply_OBC_flather .and. OBC%oblique_BCs_exist_globally) stencil = 2 + if (apply_OBC_flather .or. OBC%oblique_BCs_exist_globally) stencil = 2 if (apply_OBC_flather .and. .not.GV%Boussinesq) call MOM_error(FATAL, & "btstep: Flather open boundary conditions have not yet been "// & "implemented for a non-Boussinesq model.") endif ; endif + num_cycles = 1 + if (CS%use_wide_halos) & + num_cycles = min((is-CS%isdw) / stencil, (js-CS%jsdw) / stencil) + isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil + jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil + nstep = CEILING(dt/CS%dtbt - 0.0001) if (is_root_PE() .and. (nstep /= CS%nstep_last)) then write(mesg,'("btstep is using a dynamic barotropic timestep of ", ES12.6, & @@ -773,13 +774,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & endif call create_group_pass(CS%pass_eta_bt_rem, eta_src, CS%BT_Domain) ! The following halo updates are not needed without wide halos. RWH - if (ievf > ie) then + ! We do need them after all. +! if (ievf > ie) then call create_group_pass(CS%pass_eta_bt_rem, bt_rem_u, bt_rem_v, & CS%BT_Domain, To_All+Scalar_Pair) if (CS%linear_wave_drag) & call create_group_pass(CS%pass_eta_bt_rem, Rayleigh_u, Rayleigh_v, & CS%BT_Domain, To_All+Scalar_Pair) - endif +! endif ! The following halo update is not needed without wide halos. RWH if (((G%isd > CS%isdw) .or. (G%jsd > CS%jsdw)) .or. (Isq <= is-1) .or. (Jsq <= js-1)) & call create_group_pass(CS%pass_force_hbt0_Cor_ref, BT_force_u, BT_force_v, CS%BT_Domain) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7c848cdaf1..ebef6fd857 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -718,9 +718,9 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) "String '"//trim(action_str(a_loop))//"' not understood.") endif - if (I_obcG%HI%IedB) return ! Boundary is not on tile - if (Js_obcG%HI%JedB) return ! Segment is not on tile + if (I_obc<=G%HI%IsdB .or. I_obc>=G%HI%IedB) return ! Boundary is not on tile + if (Js_obc<=G%HI%JsdB .and. Je_obc<=G%HI%JsdB) return ! Segment is not on tile + if (Js_obc>=G%HI%JedB) return ! Segment is not on tile enddo ! a_loop OBC%segment(l_seg)%on_pe = .true. @@ -821,9 +821,9 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) "String '"//trim(action_str(a_loop))//"' not understood.") endif - if (J_obcG%HI%JedB) return ! Boundary is not on tile - if (Is_obcG%HI%IedB) return ! Segment is not on tile + if (J_obc<=G%HI%JsdB .or. J_obc>=G%HI%JedB) return ! Boundary is not on tile + if (Is_obc<=G%HI%IsdB .and. Ie_obc<=G%HI%IsdB) return ! Segment is not on tile + if (Is_obc>=G%HI%IedB) return ! Segment is not on tile enddo ! a_loop OBC%segment(l_seg)%on_pe = .true. From 2f7ad81ea49ee0743cc5966dac85697d3d9e375f Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 21 Nov 2017 11:56:57 -0500 Subject: [PATCH 015/170] Cray compilation found an issue with intent for G - G should be inout since it's passed to pass_var --- src/core/MOM_open_boundary.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7c848cdaf1..15d29cabbb 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2503,7 +2503,7 @@ end subroutine mask_outside_OBCs !> flood the cin, cout values subroutine flood_fill(G, color, cin, cout, cland) - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure real, dimension(:,:), intent(inout) :: color ! For sorting inside from outside integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain @@ -2563,7 +2563,7 @@ end subroutine flood_fill !> flood the cin, cout values subroutine flood_fill2(G, color, cin, cout, cland) - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure real, dimension(:,:), intent(inout) :: color ! For sorting inside from outside integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain From 8a239ee0f02a0945907900af774c0c8cee21e969 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 21 Nov 2017 19:39:18 -0500 Subject: [PATCH 016/170] (*)Corrected m_to_H rescaling in bulkmixedlayer Added m_to_H rescaling of H_LIMIT_FLUXES in bulkmixedlayer, so that the bulk mixed layer code now gives consistent answers when H_TO_M is changed. Answers are unchanged if H_TO_M=1, including in the test cases. --- src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index cc70ee5ebf..29e65e9a32 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -76,7 +76,7 @@ module MOM_bulk_mixed_layer ! released mean kinetic energy becomes TKE, nondim. real :: Hmix_min ! The minimum mixed layer thickness in m. real :: H_limit_fluxes ! When the total ocean depth is less than this - ! value, in m, scale away all surface forcing to + ! value, in H, scale away all surface forcing to ! avoid boiling the ocean. real :: ustar_min ! A minimum value of ustar to avoid numerical ! problems, in m s-1. If the value is small enough, @@ -3736,6 +3736,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) "The surface fluxes are scaled away when the total ocean \n"//& "depth is less than DEPTH_LIMIT_FLUXES.", & units="m", default=0.1*CS%Hmix_min) + CS%H_limit_fluxes = CS%H_limit_fluxes * GV%m_to_H call get_param(param_file, mdl, "OMEGA",CS%omega, & "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) From e49c5b0b03b04e47c2bfdb47fe6d2fb5831e244c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 21 Nov 2017 19:40:18 -0500 Subject: [PATCH 017/170] (*)Corrected H_to_m rescaling in thickness_diffuse Added H_to_m rescaling of one term in the vertical Laplacian solver form of the interface height diffusion, so that it gives consistent answers when H_TO_M is changed. Answers are unchanged if H_TO_M=1, including in the test cases. --- .../lateral/MOM_thickness_diffuse.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index a9911b297f..b3bdf4715a 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -472,8 +472,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: h_harm ! Harmonic mean layer thickness, in H. real :: c2_h_u(SZIB_(G), SZK_(G)+1) ! Wave speed squared divided by h at u-points, m s-2. real :: c2_h_v(SZI_(G), SZK_(G)+1) ! Wave speed squared divided by h at v-points, m s-2. - real :: hN2_u(SZIB_(G), SZK_(G)+1) ! Thickness times N2 at interfaces above u-points, m s-2. - real :: hN2_v(SZI_(G), SZK_(G)+1) ! Thickness times N2 at interfaces above v-points, m s-2. + real :: hN2_u(SZIB_(G), SZK_(G)+1) ! Thickness in m times N2 at interfaces above u-points, m s-2. + real :: hN2_v(SZI_(G), SZK_(G)+1) ! Thickness in m times N2 at interfaces above v-points, m s-2. real :: Sfn_est ! Two preliminary estimates (before limiting) of the ! overturning streamfunction, both in m3 s-1. real :: Sfn_unlim_u(SZIB_(G), SZK_(G)+1) ! Streamfunction for u-points (m3 s-1) @@ -659,7 +659,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect ! hN2_u is used with the FGNV streamfunction formulation - hN2_u(I,K) = 0.5*( hg2A / haA + hg2B / haB ) * max(drdz*G_rho0 , N2_floor) + hN2_u(I,K) = (0.5 * H_to_m * ( hg2A / haA + hg2B / haB )) * & + max(drdz*G_rho0 , N2_floor) endif if (present_slope_x) then Slope = slope_x(I,j,k) @@ -727,7 +728,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_u(I,K) = N2_floor * h_neglect + hN2_u(I,K) = N2_floor * dz_neglect Sfn_unlim_u(I,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_x>0) diag_sfn_unlim_x(I,j,K) = Sfn_unlim_u(I,K) @@ -904,7 +905,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect ! hN2_v is used with the FGNV streamfunction formulation - hN2_v(i,K) = 0.5*( hg2A / haA + hg2B / haB ) * max(drdz*G_rho0 , N2_floor) + hN2_v(i,K) = (0.5 * H_to_m * ( hg2A / haA + hg2B / haB )) * & + max(drdz*G_rho0 , N2_floor) endif if (present_slope_y) then Slope = slope_y(i,J,k) @@ -972,7 +974,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_v(i,K) = N2_floor * h_neglect + hN2_v(i,K) = N2_floor * dz_neglect Sfn_unlim_v(i,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_y>0) diag_sfn_unlim_y(i,J,K) = Sfn_unlim_v(i,K) From b2019a3a28dbba5d71d50af2c0219803772095bb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 21 Nov 2017 19:43:24 -0500 Subject: [PATCH 018/170] (*)Partly Correct H_to_m rescaling of MEKE code Added H_to_m rescaling of MEKE advFac, so that this particular term gives consistent answers when H_TO_M is changed, although there may be other similar issued elsewhere in the MEKE code. Also corrected the rescaling of the total thickness fluxes in a chksum call. Answers are unchanged if H_TO_M=1, including in the test cases. --- src/parameterizations/lateral/MOM_MEKE.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 8fe785be57..46a3dcacad 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -88,14 +88,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) type(MEKE_type), pointer :: MEKE !< MEKE data. type(ocean_grid_type), intent(inout) :: G !< Ocean grid. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg m-2). + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness in H (m or kg m-2). real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points (s-1). real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at u-points (s-1). type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. real, intent(in) :: dt !< Model(baroclinic) time-step (s). type(MEKE_CS), pointer :: CS !< MEKE control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: hu !< Zonal flux flux (m3). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: hv !< Meridional mass flux (m3). + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: hu !< Zonal flux flux (H m2 s-1). + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: hv !< Meridional mass flux (H m2 s-1). ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & mass, & ! The total mass of the water column, in kg m-2. @@ -112,13 +112,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) real, dimension(SZIB_(G),SZJ_(G)) :: & MEKE_uflux, & ! The zonal diffusive flux of MEKE, in kg m2 s-3. Kh_u, & ! The zonal diffusivity that is actually used, in m2 s-1. - baroHu, & ! Depth integrated zonal mass flux (m3). + baroHu, & ! Depth integrated zonal mass flux (H m2 s-1). drag_vel_u ! A (vertical) viscosity associated with bottom drag at ! u-points, in m s-1. real, dimension(SZI_(G),SZJB_(G)) :: & MEKE_vflux, & ! The meridional diffusive flux of MEKE, in kg m2 s-3. Kh_v, & ! The meridional diffusivity that is actually used, in m2 s-1. - baroHv, & ! Depth integrated meridional mass flux (m3). + baroHv, & ! Depth integrated meridional mass flux (H m2 s-1). drag_vel_v ! A (vertical) viscosity associated with bottom drag at ! v-points, in m s-1. real :: Kh_here, Inv_Kh_max, K4_here @@ -158,7 +158,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) if (associated(MEKE%GM_src)) call hchksum(MEKE%GM_src, 'MEKE GM_src',G%HI) if (associated(MEKE%MEKE)) call hchksum(MEKE%MEKE, 'MEKE MEKE',G%HI) call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI) - call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1) + call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m) endif ! Why are these 3 lines repeated from above? @@ -395,7 +395,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) !$OMP mass,mass_neglect,Kh_v,MEKE_vflux,I_mass, & !$OMP sdt_damp,drag_rate,Rho0,drag_rate_visc, & !$OMP cdrag2,bottomFac2,MEKE_decay,barotrFac2, & -!$OMP use_drag_rate,dt,baroHu,baroHv) & +!$OMP use_drag_rate,dt,baroHu,baroHv,GV) & !$OMP private(Kh_here,Inv_Kh_max,ldamping,advFac) if (CS%MEKE_KH >= 0.0 .or. CS%KhMEKE_FAC > 0.0 .or. CS%MEKE_advection_factor >0.0) then ! Lateral diffusion of MEKE @@ -428,7 +428,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) (MEKE%MEKE(i,j) - MEKE%MEKE(i,j+1)) enddo ; enddo if (CS%MEKE_advection_factor>0.) then - advFac = CS%MEKE_advection_factor / dt + advFac = GV%H_to_m * CS%MEKE_advection_factor / dt !$OMP do do j=js,je ; do I=is-1,ie if (baroHu(I,j)>0.) then From 2ae1c19940cfb4351d5ef554d8bc17462f9f3eae Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 22 Nov 2017 11:01:20 -0500 Subject: [PATCH 019/170] Fixes intent for args being updated in apply_sponge() - Issue #659 reported uninitialized values in apply_sponge(). The pertinent code increments variables passed into apply_sponge() as arguments with intent(out). The arguments should be intent(inout) in which case the values are properly initialized. - Note: none of the three compilers we use caught this mismatch and they are evidently treating intent(out) as intent(inout). Something to be wary of. - Closes #659. @hlkong for report. --- src/parameterizations/vertical/MOM_sponge.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 83be220cfe..fa9a5ac350 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -364,10 +364,10 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H (usually m or kg m-2) real, intent(in) :: dt - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: ea !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: ea !< an array to which the amount of !! fluid entrained from the layer above during !! this call will be added, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: eb !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: eb !< an array to which the amount of !! fluid entrained from the layer below !! during this call will be added, in H. type(sponge_CS), pointer :: CS From 1cded3651cb51d4055850f164750c31f1e578952 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 22 Nov 2017 12:07:10 -0900 Subject: [PATCH 020/170] Cleaning up OBC segment indices. - No longer getting array-out-of-bounds troubles. - Not quite getting the right answer with 4 PEs for rotated_seamount, but it is at least running. --- src/core/MOM_open_boundary.F90 | 86 +++++++++++++++++----------------- 1 file changed, 44 insertions(+), 42 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index ef3372f849..80bf154945 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -613,7 +613,7 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) Jeg = Jeg - G%jdg_offset ! This is the i-extent of the segment on this PE. - ! The values are nonsence if the segment is not on this PE. + ! The values are nonsense if the segment is not on this PE. seg%HI%IsdB = min( max(Isg, G%HI%IsdB), G%HI%IedB) seg%HI%IedB = min( max(Ieg, G%HI%IsdB), G%HI%IedB) seg%HI%isd = min( max(Isg+1, G%HI%isd), G%HI%ied) @@ -624,7 +624,7 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) seg%HI%iec = min( max(Ieg, G%HI%isc), G%HI%iec) ! This is the j-extent of the segment on this PE. - ! The values are nonsence if the segment is not on this PE. + ! The values are nonsense if the segment is not on this PE. seg%HI%JsdB = min( max(Jsg, G%HI%JsdB), G%HI%JedB) seg%HI%JedB = min( max(Jeg, G%HI%JsdB), G%HI%JedB) seg%HI%jsd = min( max(Jsg+1, G%HI%jsd), G%HI%jed) @@ -719,8 +719,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) endif if (I_obc<=G%HI%IsdB .or. I_obc>=G%HI%IedB) return ! Boundary is not on tile - if (Js_obc<=G%HI%JsdB .and. Je_obc<=G%HI%JsdB) return ! Segment is not on tile - if (Js_obc>=G%HI%JedB) return ! Segment is not on tile + if (Je_obc-1<=G%HI%JsdB .or. Js_obc+1>=G%HI%JedB) return ! Segment is not on tile enddo ! a_loop OBC%segment(l_seg)%on_pe = .true. @@ -822,8 +821,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) endif if (J_obc<=G%HI%JsdB .or. J_obc>=G%HI%JedB) return ! Boundary is not on tile - if (Is_obc<=G%HI%IsdB .and. Ie_obc<=G%HI%IsdB) return ! Segment is not on tile - if (Is_obc>=G%HI%IedB) return ! Segment is not on tile + if (Ie_obc-1<=G%HI%IsdB .or. Is_obc+1>=G%HI%IedB) return ! Segment is not on tile enddo ! a_loop OBC%segment(l_seg)%on_pe = .true. @@ -1264,15 +1262,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) if (.not. segment%on_pe) cycle if (segment%is_E_or_W .and. segment%radiation) then do k=1,G%ke - I=segment%HI%IscB - do j=segment%HI%jsc,segment%HI%jec + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) enddo enddo elseif (segment%is_N_or_S .and. segment%radiation) then do k=1,G%ke - J=segment%HI%JscB - do i=segment%HI%isc,segment%HI%iec + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied segment%rx_normal(i,J,k) = OBC%ry_normal(i,J,k) enddo enddo @@ -1286,8 +1284,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) if (.not. segment%on_pe) cycle if (segment%oblique) call gradient_at_q_points(G,segment,u_new,v_new) if (segment%direction == OBC_DIRECTION_E) then - I=segment%HI%IscB - do k=1,nz ; do j=segment%HI%jsc,segment%HI%jec + I=segment%HI%IsdB + if (IG%HI%IecB) cycle + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed if (segment%radiation) then dhdt = u_old(I+1,j,k)-u_new(I+1,j,k) !old-new dhdx = u_new(I+1,j,k)-u_new(I+2,j,k) !in new time forward sasha for I+1 @@ -1392,8 +1392,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if (segment%direction == OBC_DIRECTION_N) then - J=segment%HI%JscB - do k=1,nz ; do i=segment%HI%isc,segment%HI%iec + J=segment%HI%JsdB + if (JG%HI%JecB) cycle + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied if (segment%radiation) then dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new dhdy = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J-1 @@ -1525,13 +1527,13 @@ subroutine open_boundary_apply_normal_flow(OBC, G, u, v) cycle elseif (segment%radiation .or. segment%oblique .or. segment%gradient) then if (segment%is_E_or_W) then - I=segment%HI%IscB - do k=1,G%ke ; do j=segment%HI%jsc,segment%HI%jec + I=segment%HI%IsdB + do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = segment%normal_vel(I,j,k) enddo; enddo elseif (segment%is_N_or_S) then - J=segment%HI%JscB - do k=1,G%ke ; do i=segment%HI%isc,segment%HI%iec + J=segment%HI%JsdB + do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = segment%normal_vel(i,J,k) enddo; enddo endif @@ -1558,13 +1560,13 @@ subroutine open_boundary_zero_normal_flow(OBC, G, u, v) if (.not. segment%on_pe) then cycle elseif (segment%is_E_or_W) then - I=segment%HI%IscB - do k=1,G%ke ; do j=segment%HI%jsc,segment%HI%jec + I=segment%HI%IsdB + do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = 0. enddo; enddo elseif (segment%is_N_or_S) then - J=segment%HI%JscB - do k=1,G%ke ; do i=segment%HI%isc,segment%HI%iec + J=segment%HI%JsdB + do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = 0. enddo; enddo endif @@ -1584,17 +1586,17 @@ subroutine gradient_at_q_points(G,segment,uvel,vvel) if (segment%is_E_or_W) then if (segment%direction == OBC_DIRECTION_E) then - I=segment%HI%iscB + I=segment%HI%isdB do k=1,G%ke - do J=segment%HI%JscB,segment%HI%JecB + do J=max(segment%HI%JsdB, G%HI%JsdB+1),min(segment%HI%JedB, G%HI%JedB-1) segment%grad_normal(J,1,k) = (uvel(I-1,j+1,k)-uvel(I-1,j,k)) * G%mask2dBu(I-1,J) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo enddo else ! western segment - I=segment%HI%iscB + I=segment%HI%isdB do k=1,G%ke - do J=segment%HI%JscB,segment%HI%JecB + do J=max(segment%HI%JsdB, G%HI%JsdB+1),min(segment%HI%JedB, G%HI%JedB-1) segment%grad_normal(J,1,k) = (uvel(I+1,j+1,k)-uvel(I+1,j,k)) * G%mask2dBu(I+1,J) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo @@ -1602,17 +1604,17 @@ subroutine gradient_at_q_points(G,segment,uvel,vvel) endif else if (segment%is_N_or_S) then if (segment%direction == OBC_DIRECTION_N) then - J=segment%HI%jscB + J=segment%HI%jsdB do k=1,G%ke - do I=segment%HI%IscB,segment%HI%IecB + do I=max(segment%HI%IsdB, G%HI%IsdB+1),min(segment%HI%IedB, G%HI%IedB-1) segment%grad_normal(I,1,k) = (vvel(i+1,J-1,k)-vvel(i,J-1,k)) * G%mask2dBu(I,J-1) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo enddo else ! south segment - J=segment%HI%jscB + J=segment%HI%jsdB do k=1,G%ke - do I=segment%HI%IscB,segment%HI%IecB + do I=max(segment%HI%IsdB, G%HI%IsdB+1),min(segment%HI%IedB, G%HI%IedB-1) segment%grad_normal(I,1,k) = (vvel(i+1,J+1,k)-vvel(i,J+1,k)) * G%mask2dBu(I,J+1) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo @@ -1769,7 +1771,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%nudged_normal_vel(IsdB:IedB,jsd:jed,OBC%ke)); segment%nudged_normal_vel(:,:,:)=0.0 endif if (segment%oblique) then - allocate(segment%grad_normal(JscB:JecB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 endif endif @@ -1790,7 +1792,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%nudged_normal_vel(isd:ied,JsdB:JedB,OBC%ke)); segment%nudged_normal_vel(:,:,:)=0.0 endif if (segment%oblique) then - allocate(segment%grad_normal(IscB:IecB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 endif endif @@ -1973,7 +1975,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) ishift=0;jshift=0 if (segment%is_E_or_W) then if (segment%direction == OBC_DIRECTION_W) ishift=1 - I=segment%HI%IscB + I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) ! if (GV%Boussinesq) then @@ -1989,7 +1991,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) if (segment%direction == OBC_DIRECTION_S) jshift=1 - J=segment%HI%JscB + J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) ! if (GV%Boussinesq) then @@ -2503,8 +2505,8 @@ end subroutine mask_outside_OBCs !> flood the cin, cout values subroutine flood_fill(G, color, cin, cout, cland) - type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(:,:), intent(inout) :: color ! For sorting inside from outside + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain integer, intent(in) :: cland !< color for inside the land mask @@ -2563,8 +2565,8 @@ end subroutine flood_fill !> flood the cin, cout values subroutine flood_fill2(G, color, cin, cout, cland) - type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(:,:), intent(inout) :: color ! For sorting inside from outside + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain integer, intent(in) :: cland !< color for inside the land mask From c4930cbd29148f083494c8324783ae319caae7c2 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 24 Nov 2017 12:19:44 -0900 Subject: [PATCH 021/170] *Fix for rotated_seamount. - Don't need apply_eta_OBCs after all. - Found right range for segments. --- src/core/MOM_barotropic.F90 | 113 --------------------------------- src/core/MOM_open_boundary.F90 | 4 +- 2 files changed, 2 insertions(+), 115 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index b8e91cac37..bbbb7b716e 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2018,8 +2018,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) ! Should there be a concern if eta drops below 0 or G%bathyT? enddo ; enddo - if (apply_OBCs) call apply_eta_OBCs(OBC, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, iev-ie, dtbt) if (do_hifreq_output) then time_step_end = time_bt_start + set_time(int(floor(n*dtbt+0.5))) @@ -2662,117 +2660,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, end subroutine apply_velocity_OBCs -!> This subroutine applies the open boundary conditions on the free surface -!! height, as coded by Mehmet Ilicak. -subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) - type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. - type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of - !! the argument arrays. - real, dimension(SZIW_(MS),SZJW_(MS)), intent(inout) :: eta !< The barotropic free surface height anomaly - !! or column mass anomaly, in m or kg m-2. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt !< the zonal barotropic velocity, in m s-1. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt !< the meridional barotropic velocity, in m s-1. - type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays - !! related to the open boundary conditions, - !! set by set_up_BT_OBC. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - integer, intent(in) :: halo !< The extra halo size to use here. - real, intent(in) :: dtbt !< The time step, in s. - - - real :: H_u ! The total thickness at the u-point, in m or kg m-2. - real :: H_v ! The total thickness at the v-point, in m or kg m-2. - real :: cfl ! The CFL number at the point in question, ND. - real :: u_inlet - real :: v_inlet - real :: h_in - integer :: i, j, is, ie, js, je - is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo - - if (OBC%open_u_BCs_exist_globally .and. BT_OBC%apply_u_OBCS) then - do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_u(I,j))%Flather) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL - u_inlet = cfl*ubt(I-1,j) + (1.0-cfl)*ubt(I,j) ! Valid for cfl <1 -! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal - - H_u = BT_OBC%H_u(I,j) - eta(i+1,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & - (H_u/BT_OBC%Cg_u(I,j))*(u_inlet-BT_OBC%ubt_outer(I,j))) - eta(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - cfl = dtbt*BT_OBC%Cg_u(I,j)*G%IdxCu(I,j) ! CFL - u_inlet = cfl*ubt(I+1,j) + (1.0-cfl)*ubt(I,j) ! Valid for cfl <1 -! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external - h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal - - H_u = BT_OBC%H_u(I,j) - eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & - (H_u/BT_OBC%Cg_u(I,j))*(BT_OBC%ubt_outer(I,j)-u_inlet)) - eta(i+1,j) - endif - elseif (OBC%segment(OBC%segnum_u(I,j))%radiation) then - ! Chapman implicit from ROMS - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL - eta(i+1,j) = 1.0/(1 + cfl) * (eta(i,j) + cfl*eta(i-1,j)) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - cfl = dtbt*BT_OBC%Cg_u(I,j)*G%IdxCu(I,j) ! CFL - eta(i,j) = 1.0/(1 + cfl) * (eta(i+1,j) + cfl*eta(i+2,j)) - endif - elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - eta(i+1,j) = eta(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - eta(i,j) = eta(i+1,j) - endif - endif - endif ; enddo ; enddo - endif - - if (OBC%open_v_BCs_exist_globally .and. BT_OBC%apply_v_OBCs) then - do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL - v_inlet = cfl*vbt(i,J-1) + (1.0-cfl)*vbt(i,J) ! Valid for cfl <1 -! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal - - H_v = BT_OBC%H_v(i,J) - eta(i,j+1) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & - (H_v/BT_OBC%Cg_v(i,J))*(v_inlet-BT_OBC%vbt_outer(i,J))) - eta(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL - v_inlet = cfl*vbt(i,J+1) + (1.0-cfl)*vbt(i,J) ! Valid for cfl <1 -! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external - h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal - - H_v = BT_OBC%H_v(i,J) - eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & - (H_v/BT_OBC%Cg_v(i,J))*(BT_OBC%vbt_outer(i,J)-v_inlet)) - eta(i,j+1) - endif - elseif (OBC%segment(OBC%segnum_v(i,J))%radiation) then - ! Chapman implicit from ROMS - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL - eta(i,j+1) = 1.0/(1 + cfl) * (eta(i,j) + cfl*eta(i,j-1)) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL - eta(i,j) = 1.0/(1 + cfl) * (eta(i,j+1) + cfl*eta(i,j+2)) - endif - elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - eta(i,j+1) = eta(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - eta(i,j) = eta(i,j+1) - endif - endif - endif ; enddo ; enddo - endif - -end subroutine apply_eta_OBCs - !> This subroutine sets up the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, MS, halo, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 80bf154945..945fc5ad0e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -719,7 +719,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) endif if (I_obc<=G%HI%IsdB .or. I_obc>=G%HI%IedB) return ! Boundary is not on tile - if (Je_obc-1<=G%HI%JsdB .or. Js_obc+1>=G%HI%JedB) return ! Segment is not on tile + if (Je_obc<=G%HI%JsdB .or. Js_obc>=G%HI%JedB) return ! Segment is not on tile enddo ! a_loop OBC%segment(l_seg)%on_pe = .true. @@ -821,7 +821,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) endif if (J_obc<=G%HI%JsdB .or. J_obc>=G%HI%JedB) return ! Boundary is not on tile - if (Ie_obc-1<=G%HI%IsdB .or. Is_obc+1>=G%HI%IedB) return ! Segment is not on tile + if (Ie_obc<=G%HI%IsdB .or. Is_obc>=G%HI%IedB) return ! Segment is not on tile enddo ! a_loop OBC%segment(l_seg)%on_pe = .true. From 1f7a76072a69ff9958270ac11af08c6c730ad3fe Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 27 Nov 2017 10:51:16 -0900 Subject: [PATCH 022/170] Barotropic OBCs don't need stencil=2. - However, rotated_seamount does need at least a halo of 3 or else: FATAL from PE 2: In MOM_continuity_PPM, PPM_reconstruction_x called with a x-halo that needs to be increased by 1. --- src/core/MOM_barotropic.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index bbbb7b716e..6b93a14738 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -705,8 +705,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & apply_OBC_open = open_boundary_query(OBC, apply_open_OBC=.true.) apply_OBCs = open_boundary_query(OBC, apply_specified_OBC=.true.) .or. & apply_OBC_flather .or. apply_OBC_open -! if (.not.apply_OBC_flather .and. OBC%oblique_BCs_exist_globally) stencil = 2 - if (apply_OBC_flather .or. OBC%oblique_BCs_exist_globally) stencil = 2 if (apply_OBC_flather .and. .not.GV%Boussinesq) call MOM_error(FATAL, & "btstep: Flather open boundary conditions have not yet been "// & From 7e29b14ae7317f32d81e5460f8a8454bdeed6547 Mon Sep 17 00:00:00 2001 From: Travis Sluka Date: Tue, 28 Nov 2017 10:59:24 -0500 Subject: [PATCH 023/170] fixes bug when using ADJUST_NET_FRESH_WATER_TO_ZERO=True --- config_src/coupled_driver/MOM_surface_forcing.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index a9fcd00844..693533be80 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -560,15 +560,15 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, ! is constant. ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA if (ASSOCIATED(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) - G%areaT(i,j) * & + net_FW(i,j) = net_FW(i,j) + G%areaT(i,j) * & (IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) - net_FW2(i,j) = net_FW(i,j) + net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)) * G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) enddo; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf From 2e48cb69d53ddbb834df2a1d1488b7c38b1485ae Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 28 Nov 2017 11:25:48 -0500 Subject: [PATCH 024/170] (*)Use GV%Angstrom_Z in user thickness init routines Several of the user thickness initalization routines had been using GV%Angstrom in their initialization, but GV%Angstrom is in units of H whereas the thickness initialization routines have not yet been converted from m to H. In addition, there was some substantial code cleanup (e.g. proper 2 point indents and eliminating superfloux traliing semicolons) in DOME2d_initialization.F90. With this code change, the initialization of several of the test cases now reproduce answers when H_TO_M is not 1. When H_TO_M=1, all answers in the test cases are bitwise identical. --- src/user/DOME2d_initialization.F90 | 177 +++++++++++----------- src/user/lock_exchange_initialization.F90 | 4 +- src/user/sloshing_initialization.F90 | 4 +- 3 files changed, 93 insertions(+), 92 deletions(-) diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 8f901ebb66..2456b2dbc8 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -36,11 +36,11 @@ module DOME2d_initialization !> Initialize topography with a shelf and slope in a 2D domain subroutine DOME2d_initialize_topography ( D, G, param_file, max_depth ) ! Arguments - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m - type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum depth of model in m + intent(out) :: D !< Ocean bottom depth in m + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum depth of model in m ! Local variables integer :: i, j real :: x, bay_depth, l1, l2 @@ -67,23 +67,22 @@ subroutine DOME2d_initialize_topography ( D, G, param_file, max_depth ) bay_depth = dome2d_depth_bay - do i=G%isc,G%iec - do j=G%jsc,G%jec + do j=G%jsc,G%jec ; do i=G%isc,G%iec - ! Compute normalized zonal coordinate - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon; + ! Compute normalized zonal coordinate + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - if ( x .le. l1 ) then - D(i,j) = bay_depth * max_depth - else if (( x .gt. l1 ) .and. ( x .lt. l2 )) then - D(i,j) = bay_depth * max_depth + (1.0-bay_depth) * max_depth * & - ( x - l1 ) / (l2 - l1) - else - D(i,j) = max_depth - end if + if ( x <= l1 ) then + D(i,j) = bay_depth * max_depth + else if (( x > l1 ) .and. ( x < l2 )) then + D(i,j) = bay_depth * max_depth + (1.0-bay_depth) * max_depth * & + ( x - l1 ) / (l2 - l1) + else + D(i,j) = max_depth + endif + + enddo ; enddo - enddo - enddo end subroutine DOME2d_initialize_topography !> Initialize thicknesses according to coordinate mode @@ -157,56 +156,56 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params endif enddo - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon; - if ( x .le. dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom; - h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom; - end if + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + h(i,j,1:nz-1) = GV%Angstrom_Z + h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z + endif - end do ; end do + enddo ; enddo ! case ( IC_RHO_C ) ! ! do j=js,je ; do i=is,ie - ! eta1D(nz+1) = -1.0*G%bathyT(i,j) - ! do k=nz,1,-1 - ! eta1D(k) = e0(k) - ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then - ! eta1D(k) = eta1D(k+1) + min_thickness - ! h(i,j,k) = min_thickness - ! else - ! h(i,j,k) = eta1D(k) - eta1D(k+1) - ! endif + ! eta1D(nz+1) = -1.0*G%bathyT(i,j) + ! do k=nz,1,-1 + ! eta1D(k) = e0(k) + ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + ! eta1D(k) = eta1D(k+1) + min_thickness + ! h(i,j,k) = min_thickness + ! else + ! h(i,j,k) = eta1D(k) - eta1D(k+1) + ! endif ! enddo ! - ! x = G%geoLonT(i,j) / G%len_lon; - ! if ( x .le. dome2d_width_bay ) then - ! h(i,j,1:nz-1) = min_thickness; - ! h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness; - ! end if + ! x = G%geoLonT(i,j) / G%len_lon + ! if ( x <= dome2d_width_bay ) then + ! h(i,j,1:nz-1) = min_thickness + ! h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness + ! endif ! ! enddo ; enddo case ( REGRIDDING_ZSTAR ) do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) - do k=nz,1,-1 - eta1D(k) = e0(k) - if (eta1D(k) < (eta1D(k+1) + min_thickness)) then - eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness - else - h(i,j,k) = eta1D(k) - eta1D(k+1) - endif - enddo + eta1D(nz+1) = -1.0*G%bathyT(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo enddo ; enddo case ( REGRIDDING_SIGMA ) do j=js,je ; do i=is,ie - delta_h = G%bathyT(i,j) / nz; - h(i,j,:) = delta_h; - end do ; end do + delta_h = G%bathyT(i,j) / nz + h(i,j,:) = delta_h + enddo ; enddo case default call MOM_error(FATAL,"dome2d_initialize: "// & @@ -231,12 +230,12 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & ! Local variables integer :: i, j, k, is, ie, js, je, nz - real :: x; - integer :: index_bay_z; - real :: delta_S, delta_T; + real :: x + integer :: index_bay_z + real :: delta_S, delta_T real :: S_ref, T_ref; ! Reference salinity and temperature within surface layer real :: S_range, T_range; ! Range of salinities and temperatures over the vertical - real :: xi0, xi1; + real :: xi0, xi1 logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: verticalCoordinate real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay @@ -274,35 +273,35 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) do j=js,je ; do i=is,ie - xi0 = 0.0; + xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth; - S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1); - xi0 = xi1; + xi1 = xi0 + h(i,j,k) / G%max_depth + S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) + xi0 = xi1 enddo enddo ; enddo case ( REGRIDDING_RHO ) do j=js,je ; do i=is,ie - xi0 = 0.0; + xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth; - S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1); - xi0 = xi1; + xi1 = xi0 + h(i,j,k) / G%max_depth + S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) + xi0 = xi1 enddo - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon; - if ( x .le. dome2d_width_bay ) then - S(i,j,nz) = 34.0 + S_range; + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + S(i,j,nz) = 34.0 + S_range endif enddo ; enddo case ( REGRIDDING_LAYER ) - delta_S = S_range / ( G%ke - 1.0 ); - S(:,:,1) = S_ref; + delta_S = S_range / ( G%ke - 1.0 ) + S(:,:,1) = S_ref do k = 2,G%ke - S(:,:,k) = S(:,:,k-1) + delta_S; + S(:,:,k) = S(:,:,k-1) + delta_S enddo case default @@ -313,10 +312,10 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & ! Modify salinity and temperature when z coordinates are used if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_ZSTAR ) then - index_bay_z = Nint ( dome2d_depth_bay * G%ke ); + index_bay_z = Nint ( dome2d_depth_bay * G%ke ) do j = G%jsc,G%jec ; do i = G%isc,G%iec - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon; - if ( x .le. dome2d_width_bay ) then + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then S(i,j,1:index_bay_z) = S_ref + S_range; ! Use for z coordinates T(i,j,1:index_bay_z) = 1.0; ! Use for z coordinates endif @@ -326,8 +325,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & ! Modify salinity and temperature when sigma coordinates are used if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_SIGMA ) then do i = G%isc,G%iec ; do j = G%jsc,G%jec - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon; - if ( x .le. dome2d_width_bay ) then + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then S(i,j,1:G%ke) = S_ref + S_range; ! Use for sigma coordinates T(i,j,1:G%ke) = 1.0; ! Use for sigma coordinates endif @@ -335,15 +334,16 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & endif ! Modify temperature when rho coordinates are used - T(G%isc:G%iec,G%jsc:G%jec,1:G%ke) = 0.0; - if (( coordinateMode(verticalCoordinate) .eq. REGRIDDING_RHO ) .or. ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_LAYER )) then + T(G%isc:G%iec,G%jsc:G%jec,1:G%ke) = 0.0 + if (( coordinateMode(verticalCoordinate) .eq. REGRIDDING_RHO ) .or. & + ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_LAYER )) then do i = G%isc,G%iec ; do j = G%jsc,G%jec - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon; - if ( x .le. dome2d_width_bay ) then - T(i,j,G%ke) = 1.0; - end if - end do ; end do - end if + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + T(i,j,G%ke) = 1.0 + endif + enddo ; enddo + endif end subroutine DOME2d_initialize_temperature_salinity @@ -466,7 +466,8 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) do k = nz,1,-1 z = z + 0.5 * h(i,j,k) ! Position of the center of layer k S(i,j,k) = 34.0 - 1.0 * (z/G%max_depth) - if ( ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon < dome2d_west_sponge_width ) S(i,j,k) = S_ref + S_range + if ( ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon < dome2d_west_sponge_width ) & + S(i,j,k) = S_ref + S_range z = z + 0.5 * h(i,j,k) ! Position of the interface k enddo enddo ; enddo @@ -493,11 +494,11 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) endif enddo - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon; - if ( x .le. dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom; - h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom; - end if + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + h(i,j,1:nz-1) = GV%Angstrom + h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom + endif eta(i,j,nz+1) = -G%bathyT(i,j) do K=nz,1,-1 diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index 78c6671243..72835f6d2d 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -76,11 +76,11 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, param_file, just_read_pa enddo eta1D(nz+1) = -G%max_depth ! Force bottom interface to bottom do k=nz,2,-1 ! Make sure interfaces increase upwards - eta1D(K) = max( eta1D(K), eta1D(K+1) + GV%Angstrom ) + eta1D(K) = max( eta1D(K), eta1D(K+1) + GV%Angstrom_Z ) enddo eta1D(1) = 0. ! Force bottom interface to bottom do k=2,nz ! Make sure interfaces decrease downwards - eta1D(K) = min( eta1D(K), eta1D(K-1) - GV%Angstrom ) + eta1D(K) = min( eta1D(K), eta1D(K-1) - GV%Angstrom_Z ) enddo do k=nz,1,-1 h(i,j,k) = eta1D(K) - eta1D(K+1) diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 3a28441687..6a72c7bd9f 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -160,8 +160,8 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param ! are strictly positive do k = nz,1,-1 - if ( z_inter(k) .LT. (z_inter(k+1) + GV%Angstrom) ) then - z_inter(k) = z_inter(k+1) + GV%Angstrom + if ( z_inter(k) .LT. (z_inter(k+1) + GV%Angstrom_Z) ) then + z_inter(k) = z_inter(k+1) + GV%Angstrom_Z end if end do From 737109662a4beaa18a6e194521c405c19d5458c5 Mon Sep 17 00:00:00 2001 From: Travis Sluka Date: Tue, 28 Nov 2017 15:06:39 -0500 Subject: [PATCH 025/170] fixes bug when using ADJUST_NET_FRESH_WATER_BY_SCALING=True --- config_src/coupled_driver/MOM_surface_forcing.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index a9fcd00844..27823e244f 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -562,13 +562,13 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, if (ASSOCIATED(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & net_FW(i,j) = net_FW(i,j) - G%areaT(i,j) * & (IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) - net_FW2(i,j) = net_FW(i,j) + net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)) * G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) enddo; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf From d9120c9d91482d15846f8a911b467dee8af1b0f5 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 28 Nov 2017 13:06:20 -0800 Subject: [PATCH 026/170] Added an absolute value when checking for convergence --- src/tracer/MOM_neutral_diffusion_aux.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 1d17c7a895..74f0129b94 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -228,6 +228,11 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re return endif + if ( delta_rho_init > 0.) then + refine_nondim_position = 1. + return + endif + if (debug) then write (*,*) "------" write (*,*) "Starting x0, delta_rho: ", min_bound, delta_rho @@ -271,11 +276,14 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re b_last = b b = (P_int-P_top)/delta_P ! Test to see if it fell out of the bracketing interval. If so, take a bisection step - if (b < a .or. b > c) b = 0.5*(a + c) + if (b < a .or. b > c) then + b = 0.5*(a + c) + endif endif call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & b, ref_pres, EOS, fb, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) - if (ABS(fb) <= tolerance .or. (b-b_last) <= tolerance ) then + if (debug) print *, "Iteration, b, fb: ", iter, b, fb + if (ABS(fb) <= tolerance .or. ABS(b-b_last) <= tolerance ) then refine_nondim_position = P_int/delta_P exit endif From 33ecaea76729ac14ccc92b76d72434b3234c020c Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 28 Nov 2017 13:06:51 -0800 Subject: [PATCH 027/170] Modify logic to allow for small, but non-zero criterion for neutral density --- src/tracer/MOM_neutral_diffusion.F90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 8820a423af..4ff3c55062 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1434,7 +1434,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, ! Set position within the searched column call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & - lastP_left, lastK_left, kl_left, kl_left_0, ki_left, top_connected_l, bot_connected_l, & + lastP_left, lastK_left, kl_left, kl_left_0, ki_left, tolerance, top_connected_l, bot_connected_l, & PoL(k_surface), KoL(k_surface)) if ( refine_pos .and. (PoL(k_surface) > 0.) .and. (PoL(k_surface) < 1.) ) then min_bound = 0. @@ -1483,7 +1483,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, ! Set position within the searched column call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), & - lastP_right, lastK_right, kl_right, kl_right_0, ki_right, top_connected_r, bot_connected_r, & + lastP_right, lastK_right, kl_right, kl_right_0, ki_right, tolerance, top_connected_r, bot_connected_r, & PoR(k_surface), KoR(k_surface)) if ( refine_pos .and. (PoR(k_surface) > 0. .and. PoR(k_surface) < 1.) ) then min_bound = 0. @@ -1586,7 +1586,7 @@ end subroutine increment_interface !> Searches the "other" (searched) column for the position of the neutral surface subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, kl_0, ki, & - top_connected, bot_connected, out_P, out_K) + tolerance, top_connected, bot_connected, out_P, out_K) real, intent(in ) :: dRhoTopm1 !< Density difference across previous interface real, intent(in ) :: dRhoTop !< Density difference across top interface real, intent(in ) :: dRhoBot !< Density difference across top interface @@ -1597,6 +1597,7 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, integer, intent(in ) :: kl !< Layer in the searched column integer, intent(in ) :: kl_0 !< Layer in the searched column integer, intent(in ) :: ki !< Interface of the searched column + real, intent(in ) :: tolerance !< How close to 0 "neutral" is defined logical, dimension(:), intent(inout) :: top_connected !< True if the top interface was pointed to logical, dimension(:), intent(inout) :: bot_connected !< True if the top interface was pointed to real, intent( out) :: out_P !< Position within searched column @@ -1604,15 +1605,15 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, if (kl > kl_0) then ! Away from top cell if (kl == lastK) then ! Searching in the same layer - if (dRhoTop > 0.) then + if (dRhoTop > tolerance) then out_P = max(0.,lastP) ; out_K = kl - elseif (dRhoTop == dRhoBot) then + elseif ( ABS(dRhoTop - dRhoBot)= dRhoBot) then + elseif (dRhoTop >= (dRhoBot+tolerance)) then out_P = 1. ; out_K = kl else out_K = kl @@ -1630,15 +1631,15 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, else ! At the top cell if (ki == 1) then out_P = 0. ; out_K = kl - elseif (dRhoTop > 0.) then + elseif (dRhoTop > tolerance) then out_P = max(0.,lastP) ; out_K = kl - elseif (dRhoTop == dRhoBot) then + elseif ( (dRhoTop - dRhoBot)= dRhoBot) then + elseif (dRhoTop >= (dRhoBot+tolerance)) then out_P = 1. ; out_K = kl else out_K = kl From 042e843b0f075503f73ca5acae84092b3599b7ba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 Nov 2017 10:57:58 -0500 Subject: [PATCH 028/170] (*)Fix depth based masking of slope*N Correct the rescaling the bottom for determining a de-facto land mask to determine when to assume a slope*N = 0 in calc_slope_functions_using_just_e. This function needs to be recoded to handle arbitrary topogrpahic reference levels and use the total water thickness instead of the bottom depth. This change can change answers when H_TO_M is not 1, but by default all test cases are bitwise identical. --- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 7f981f7c04..226f40f59b 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -693,7 +693,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) do I=is-1,ie !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(I,j), G%bathyT(I+1,j)) + GV%Angstrom ) ) !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff ) then + if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff*GV%H_to_m ) then CS%SN_u(I,j) = G%mask2dCu(I,j) * sqrt( CS%SN_u(I,j) / max(G%bathyT(I,j), G%bathyT(I+1,j)) ) else CS%SN_u(I,j) = 0.0 @@ -708,7 +708,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) do i=is,ie !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + GV%Angstrom ) ) !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff ) then + if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff*GV%H_to_m ) then CS%SN_v(i,J) = G%mask2dCv(i,J) * sqrt( CS%SN_v(i,J) / max(G%bathyT(i,J), G%bathyT(i,J+1)) ) else CS%SN_v(I,j) = 0.0 From 86d66f5265394e199fa0534e65b9b29e6025266e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 Nov 2017 10:58:32 -0500 Subject: [PATCH 029/170] (*)Rescale eta_bt by H_TO_M in find_eta_2d The optional argument eta_bt to find_eta_2d has units of H, but was being treated in the 2-d Boussinesq case as though it has units of m. This has now been corrected. This change can change answers when H_TO_M is not 1, but by default all test cases are bitwise identical. --- src/core/MOM_interface_heights.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 5e7de41aed..f30bcda8cb 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -184,7 +184,7 @@ subroutine find_eta_2d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) if (present(eta_bt)) then !$OMP do do j=js,je ; do i=is,ie - eta(i,j) = eta_bt(i,j) + eta(i,j) = GV%H_to_m*eta_bt(i,j) enddo ; enddo else !$OMP do From 82df597b74d469eef322be9f2ab8eb8df958e8e9 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 29 Nov 2017 10:57:29 -0900 Subject: [PATCH 030/170] New dyed_channel OBC option - adds to MOM_parameter_doc.all - has both dye and supercritical-type flow input - dyed_obc and dyed_channel have NUM_DYE_TRACERS dyes, runtime parameter - only invoke vertical diffusion for nz > 1 --- .../MOM_state_initialization.F90 | 4 + src/tracer/dye_example.F90 | 42 +++--- src/tracer/dyed_obc_tracer.F90 | 82 ++++++++---- src/user/dyed_channel_initialization.F90 | 124 ++++++++++++++++++ src/user/dyed_obcs_initialization.F90 | 21 ++- src/user/supercritical_initialization.F90 | 5 - 6 files changed, 216 insertions(+), 62 deletions(-) create mode 100644 src/user/dyed_channel_initialization.F90 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index f70ebe9be9..67d26d2a34 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -75,6 +75,7 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init use SCM_CVmix_tests, only: SCM_CVmix_tests_TS_init +use dyed_channel_initialization, only : dyed_channel_set_OBC_data use dyed_obcs_initialization, only : dyed_obcs_set_OBC_data use supercritical_initialization, only : supercritical_set_OBC_data use soliton_initialization, only : soliton_initialize_velocity @@ -535,6 +536,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "A string that sets how the user code is invoked to set open\n"//& " boundary data: \n"//& " DOME - specified inflow on northern boundary\n"//& + " dyed_channel - supercritical with dye on the inflow boundary\n"//& " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& " Kelvin - barotropic Kelvin wave forcing on the western boundary\n"//& " shelfwave - Flather with shelf wave forcing on western boundary\n"//& @@ -543,6 +545,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " USER - user specified", default="none") if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) + elseif (trim(config) == "dyed_channel") then + call dyed_channel_set_OBC_data(OBC, G, GV, PF, tracer_Reg) elseif (trim(config) == "dyed_obcs") then call dyed_obcs_set_OBC_data(OBC, G, GV, PF, tracer_Reg) elseif (trim(config) == "Kelvin") then diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 87bae7bd6b..da7439f6a8 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -2,27 +2,27 @@ module regional_dyes ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time -use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values -use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type - -use coupler_types_mod, only : coupler_type_set_data, ind_csurf +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl +use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type, get_time +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type + +use coupler_types_mod, only : coupler_type_set_data, ind_csurf use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux implicit none ; private diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 435bcf5a2a..21c0a4009a 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -30,14 +30,12 @@ module dyed_obc_tracer public register_dyed_obc_tracer, initialize_dyed_obc_tracer public dyed_obc_tracer_column_physics, dyed_obc_tracer_end -! ntr is the number of tracers in this module. -integer, parameter :: NTR = 4 - type p3d real, dimension(:,:,:), pointer :: p => NULL() end type p3d type, public :: dyed_obc_tracer_CS ; private + integer :: ntr ! The number of tracers that are actually used. logical :: coupled_tracers = .false. ! These tracers are not offered to the ! coupler. character(len=200) :: tracer_IC_file ! The full path to the IC file, or " " @@ -46,23 +44,23 @@ module dyed_obc_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR) :: & + type(p3d), allocatable, dimension(:) :: & tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. - real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. - integer, dimension(NTR) :: ind_tr ! Indices returned by aof_set_coupler_flux - ! if it is used and the surface tracer concentrations are to be - ! provided to the coupler. + integer, allocatable, dimension(:) :: & + ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the + ! surface tracer concentrations are to be provided to the coupler. + id_tracer, id_tr_adx, id_tr_ady, & + id_tr_dfx, id_tr_dfy type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. - integer, dimension(NTR) :: id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1 - integer, dimension(NTR) :: id_tr_dfx = -1, id_tr_dfy = -1 + type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(vardesc) :: tr_desc(NTR) + type(vardesc), allocatable :: tr_desc(:) end type dyed_obc_tracer_CS contains @@ -84,6 +82,8 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) #include "version_variable.h" character(len=40) :: mdl = "dyed_obc_tracer" ! This module's name. character(len=200) :: inputdir + character(len=48) :: var_name ! The variable's name. + character(len=48) :: desc_name ! The variable's descriptor. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_dyed_obc_tracer integer :: isd, ied, jsd, jed, nz, m @@ -98,6 +98,27 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0) + allocate(CS%tr_adx(CS%ntr), & + CS%tr_ady(CS%ntr), & + CS%tr_dfx(CS%ntr), & + CS%tr_dfy(CS%ntr)) + allocate(CS%ind_tr(CS%ntr), & + CS%id_tracer(CS%ntr), & + CS%id_tr_adx(CS%ntr), & + CS%id_tr_ady(CS%ntr), & + CS%id_tr_dfx(CS%ntr), & + CS%id_tr_dfy(CS%ntr)) + allocate(CS%tr_desc(CS%ntr)) + + CS%id_tracer(:) = -1 + CS%id_tr_adx(:) = -1 + CS%id_tr_ady(:) = -1 + CS%id_tr_dfx(:) = -1 + CS%id_tr_dfy(:) = -1 + call get_param(param_file, mdl, "dyed_obc_TRACER_IC_FILE", CS%tracer_IC_file, & "The name of a file from which to read the initial \n"//& "conditions for the dyed_obc tracers, or blank to initialize \n"//& @@ -110,11 +131,11 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tracer_IC_file) endif - allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 - do m=1,NTR - write(name,'("dye_",I1.1)') m - write(longname,'("Concentration of dyed_obc Tracer ",I1.1)') m + do m=1,CS%ntr + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) ! This is needed to force the compiler not to do a copy in the registration @@ -135,10 +156,11 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) enddo CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS register_dyed_obc_tracer = .true. end function register_dyed_obc_tracer -!> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) +!> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & diag_to_Z_CSp) @@ -162,7 +184,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come ! in through u- and v- points through the open ! boundary conditions, in the same units as tr. - character(len=16) :: name ! A variable's name in a NetCDF file. + character(len=24) :: name ! A variable's name in a NetCDF file. character(len=72) :: longname ! The long name of that variable. character(len=48) :: units ! The dimensions of the variable. character(len=48) :: flux_units ! The units for tracer fluxes, usually @@ -175,6 +197,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return + if (CS%ntr < 1) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -189,12 +212,12 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & call MOM_error(FATAL, "dyed_obc_initialize_tracer: Unable to open "// & CS%tracer_IC_file) - do m=1,NTR + do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name, caller="initialize_dyed_obc_tracer") call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) enddo else - do m=1,NTR + do m=1,CS%ntr do k=1,nz ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 0.0 enddo ; enddo ; enddo @@ -206,7 +229,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" else ; flux_units = "kg s-1" ; endif - do m=1,NTR + do m=1,CS%ntr ! Register the tracer for the restart file. call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & caller="initialize_dyed_obc_tracer") @@ -277,23 +300,24 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return + if (CS%ntr < 1) return if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - do m=1,NTR + do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie - h_work(i,j,k) = h_old(i,j,k) + h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo; call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else - do m=1,NTR - call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + do m=1,CS%ntr + if (nz > 1) call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo endif - do m=1,NTR + do m=1,CS%ntr if (CS%id_tracer(m)>0) & call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) if (CS%id_tr_adx(m)>0) & @@ -315,7 +339,7 @@ subroutine dyed_obc_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,NTR + do m=1,CS%ntr if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) @@ -328,7 +352,8 @@ end subroutine dyed_obc_tracer_end !> \namespace dyed_obc_tracer !! * -!! By Kate Hedstrom, 2017, copied from DOME tracers. * +!! By Kate Hedstrom, 2017, copied from DOME tracers and also * +!! dye_example. * !! * !! This file contains an example of the code that is needed to set * !! up and use a set of dynamically passive tracers. These tracers * @@ -341,7 +366,6 @@ end subroutine dyed_obc_tracer_end !! chemistry along with diapycnal mixing (included here because some * !! tracers may float or swim vertically or dye diapycnal processes). * !! * -!! * !! Macros written all in capital letters are defined in MOM_memory.h. * !! * !! A small fragment of the grid is shown below: * diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 new file mode 100644 index 0000000000..a025344cac --- /dev/null +++ b/src/user/dyed_channel_initialization.F90 @@ -0,0 +1,124 @@ +module dyed_channel_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : vardesc, var_desc +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_tracer_registry, only : tracer_registry_type, add_tracer_OBC_values +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public dyed_channel_set_OBC_data + +integer :: ntr = 0 + +contains + +!> This subroutine sets the dye and flow properties at open boundary conditions. +subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + +! Local variables + character(len=40) :: mdl = "dyed_channel_set_OBC_data" ! This subroutine's name. + character(len=80) :: name, longname + real :: zonal_flow + integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n, nz + integer :: IsdB, IedB, JsdB, JedB + real :: dye + type(OBC_segment_type), pointer :: segment + type(vardesc), allocatable, dimension(:) :: tr_desc + + nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & + 'dyed_channel_set_OBC_data() was called but OBC type was not initialized!') + + call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", zonal_flow, & + "Constant zonal flow imposed at upstream open boundary.", & + units="m/s", default=8.57) + + do l=1, OBC%number_of_segments + segment => OBC%segment(l) + if (.not. segment%on_pe) cycle + if (segment%gradient) cycle + if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle + + if (segment%is_E_or_W) then + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + do k=1,G%ke + do j=jsd,jed ; do I=IsdB,IedB + if (segment%specified .or. segment%nudged) then + segment%normal_vel(I,j,k) = zonal_flow + endif + if (segment%specified) then + segment%normal_trans(I,j,k) = zonal_flow * G%dyCu(I,j) + endif + enddo ; enddo + enddo + do j=jsd,jed ; do I=IsdB,IedB + segment%normal_vel_bt(I,j) = zonal_flow + enddo ; enddo + else + isd = segment%HI%isd ; ied = segment%HI%ied + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + do J=JsdB,JedB ; do i=isd,ied + segment%normal_vel_bt(i,J) = 0.0 + enddo ; enddo + endif + enddo + + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments .lt. ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") + return !!! Need a better error message here + endif + allocate(tr_desc(ntr)) + +! ! Set the inflow values of the dyes, one per segment. +! ! We know the order: north, south, east, west + do m=1,ntr + write(name,'("dye_",I1.1)') m + write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m + tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + + do n=1,OBC%number_of_segments + if (n == m) then + dye = 1.0 + else + dye = 0.0 + endif + call register_segment_tracer(tr_desc(m), param_file, GV, & + OBC%segment(n), OBC_scalar=dye) + enddo + enddo + deallocate(tr_desc) + +end subroutine dyed_channel_set_OBC_data + +!> \namespace dyed_channel_initialization +!! Setting dyes, one for painting the inflow on each side. +end module dyed_channel_initialization diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index e1acea3948..8e490890d1 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -3,7 +3,7 @@ module dyed_obcs_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type @@ -20,7 +20,7 @@ module dyed_obcs_initialization public dyed_obcs_set_OBC_data -integer, parameter :: NTR = 4 +integer :: ntr = 0 contains @@ -42,7 +42,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) integer :: IsdB, IedB, JsdB, JedB real :: dye type(OBC_segment_type), pointer :: segment - type(vardesc) :: tr_desc(NTR) + type(vardesc), allocatable, dimension(:) :: tr_desc is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -50,19 +50,25 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) if (.not.associated(OBC)) return - if (OBC%number_of_segments .ne. 4) then - print *, 'Error in dyed_obcs segment setup' + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments .lt. ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") return !!! Need a better error message here endif + allocate(tr_desc(ntr)) ! ! Set the inflow values of the dyes, one per segment. ! ! We know the order: north, south, east, west - do m=1,NTR + do m=1,ntr write(name,'("dye_",I1.1)') m write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) - do n=1,NTR + do n=1,OBC%number_of_segments if (n == m) then dye = 1.0 else @@ -72,6 +78,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) OBC%segment(n), OBC_scalar=dye) enddo enddo + deallocate(tr_desc) end subroutine dyed_obcs_set_OBC_data diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index 862b078750..f0104dd333 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -68,11 +68,6 @@ subroutine supercritical_set_OBC_data(OBC, G, param_file) else isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB -! do k=1,G%ke -! do J=JsdB,JedB ; do i=isd,ied -! segment%normal_vel(i,J,k) = 0.0 -! enddo ; enddo -! enddo do J=JsdB,JedB ; do i=isd,ied segment%normal_vel_bt(i,J) = 0.0 enddo ; enddo From 8e4348caf5dbda06566b950e1f9561aa3c7f040e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 30 Nov 2017 15:07:32 -0900 Subject: [PATCH 031/170] Fix up dyed_channel for both tracers and time-dependence - Needs OBC tracer registry - Needs boundary update call --- src/core/MOM_boundary_update.F90 | 26 ++- .../MOM_state_initialization.F90 | 5 +- src/user/dyed_channel_initialization.F90 | 160 +++++++++++++----- src/user/dyed_obcs_initialization.F90 | 4 +- src/user/shelfwave_initialization.F90 | 2 +- 5 files changed, 139 insertions(+), 58 deletions(-) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index d56f3ed589..abcfcc8807 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -22,6 +22,8 @@ module MOM_boundary_update use Kelvin_initialization, only : Kelvin_OBC_end, Kelvin_OBC_CS use shelfwave_initialization, only : shelfwave_set_OBC_data, register_shelfwave_OBC use shelfwave_initialization, only : shelfwave_OBC_end, shelfwave_OBC_CS +use dyed_channel_initialization, only : dyed_channel_update_flow, register_dyed_channel_OBC +use dyed_channel_initialization, only : dyed_channel_OBC_end, dyed_channel_OBC_CS implicit none ; private @@ -35,10 +37,12 @@ module MOM_boundary_update logical :: use_Kelvin = .false. logical :: use_tidal_bay = .false. logical :: use_shelfwave = .false. + logical :: use_dyed_channel = .false. type(file_OBC_CS), pointer :: file_OBC_CSp => NULL() type(Kelvin_OBC_CS), pointer :: Kelvin_OBC_CSp => NULL() type(tidal_bay_OBC_CS), pointer :: tidal_bay_OBC_CSp => NULL() type(shelfwave_OBC_CS), pointer :: shelfwave_OBC_CSp => NULL() + type(dyed_channel_OBC_CS), pointer :: dyed_channel_OBC_CSp => NULL() end type update_OBC_CS integer :: id_clock_pass @@ -78,6 +82,9 @@ subroutine call_OBC_register(param_file, CS, OBC) call get_param(param_file, mdl, "USE_SHELFWAVE_OBC", CS%use_shelfwave, & "If true, use the shelfwave open boundary.", & default=.false.) + call get_param(param_file, mdl, "USE_DYED_CHANNEL_OBC", CS%use_dyed_channel, & + "If true, use the dyed channel open boundary.", & + default=.false.) if (CS%use_files) CS%use_files = & register_file_OBC(param_file, CS%file_OBC_CSp, & @@ -91,18 +98,21 @@ subroutine call_OBC_register(param_file, CS, OBC) if (CS%use_shelfwave) CS%use_shelfwave = & register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, & OBC%OBC_Reg) + if (CS%use_dyed_channel) CS%use_dyed_channel = & + register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, & + OBC%OBC_Reg) end subroutine call_OBC_register !> Calls appropriate routine to update the open boundary conditions. subroutine update_OBC_data(OBC, G, GV, tv, h, CS, Time) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(update_OBC_CS), pointer :: CS !< Control structure for OBCs - type(time_type), intent(in) :: Time !< Model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(time_type), intent(in) :: Time !< Model time ! Local variables logical :: read_OBC_eta = .false. logical :: read_OBC_uv = .false. @@ -126,6 +136,8 @@ subroutine update_OBC_data(OBC, G, GV, tv, h, CS, Time) call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, h, Time) if (CS%use_shelfwave) & call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, h, Time) + if (CS%use_dyed_channel) & + call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, Time) if (OBC%needs_IO_for_data) & call update_OBC_segment_data(G, GV, OBC, tv, h, Time) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 67d26d2a34..3cfb739bca 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -75,7 +75,7 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init use SCM_CVmix_tests, only: SCM_CVmix_tests_TS_init -use dyed_channel_initialization, only : dyed_channel_set_OBC_data +use dyed_channel_initialization, only : dyed_channel_set_OBC_tracer_data use dyed_obcs_initialization, only : dyed_obcs_set_OBC_data use supercritical_initialization, only : supercritical_set_OBC_data use soliton_initialization, only : soliton_initialize_velocity @@ -546,7 +546,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) elseif (trim(config) == "dyed_channel") then - call dyed_channel_set_OBC_data(OBC, G, GV, PF, tracer_Reg) + call dyed_channel_set_OBC_tracer_data(OBC, G, GV, PF, tracer_Reg) + OBC%update_OBC = .true. elseif (trim(config) == "dyed_obcs") then call dyed_obcs_set_OBC_data(OBC, G, GV, PF, tracer_Reg) elseif (trim(config) == "Kelvin") then diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index a025344cac..0974d15671 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -10,6 +10,8 @@ module dyed_channel_initialization use MOM_io, only : vardesc, var_desc use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_open_boundary, only : OBC_registry_type, register_OBC +use MOM_time_manager, only : time_type, set_time, time_type_to_real use MOM_tracer_registry, only : tracer_registry_type, add_tracer_OBC_values use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -18,14 +20,59 @@ module dyed_channel_initialization #include -public dyed_channel_set_OBC_data +public dyed_channel_set_OBC_tracer_data, dyed_channel_OBC_end +public register_dyed_channel_OBC, dyed_channel_update_flow + +!> Control structure for tidal bay open boundaries. +type, public :: dyed_channel_OBC_CS ; private + real :: zonal_flow = 8.57 !< Maximum inflow + real :: frequency = 0.0 !< Inflow frequency +end type dyed_channel_OBC_CS integer :: ntr = 0 contains +!> Add dyed channel to OBC registry. +function register_dyed_channel_OBC(param_file, CS, OBC_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(dyed_channel_OBC_CS), pointer :: CS !< tidal bay control structure. + type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + logical :: register_dyed_channel_OBC + character(len=32) :: casename = "dyed channel" !< This case's name. + character(len=40) :: mdl = "register_dyed_channel_OBC" ! This subroutine's name. + + if (associated(CS)) then + call MOM_error(WARNING, "register_dyed_channel_OBC called with an "// & + "associated control structure.") + return + endif + allocate(CS) + + call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", CS%zonal_flow, & + "Constant zonal flow imposed at upstream open boundary.", & + units="m/s", default=8.57) + call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & + "Frequency of oscillating zonal flow.", & + units="s-1", default=0.0) + + ! Register the open boundaries. + call register_OBC(casename, param_file, OBC_Reg) + register_dyed_channel_OBC = .true. + +end function register_dyed_channel_OBC + +!> Clean up the dyed_channel OBC from registry. +subroutine dyed_channel_OBC_end(CS) + type(dyed_channel_OBC_CS), pointer :: CS !< tidal bay control structure. + + if (associated(CS)) then + deallocate(CS) + endif +end subroutine dyed_channel_OBC_end + !> This subroutine sets the dye and flow properties at open boundary conditions. -subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) +subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -36,25 +83,71 @@ subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables - character(len=40) :: mdl = "dyed_channel_set_OBC_data" ! This subroutine's name. + character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname - real :: zonal_flow - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n, nz + integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n integer :: IsdB, IedB, JsdB, JedB real :: dye type(OBC_segment_type), pointer :: segment type(vardesc), allocatable, dimension(:) :: tr_desc - nz = G%ke - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & 'dyed_channel_set_OBC_data() was called but OBC type was not initialized!') - call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", zonal_flow, & - "Constant zonal flow imposed at upstream open boundary.", & - units="m/s", default=8.57) + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments .lt. ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") + return !!! Need a better error message here + endif + allocate(tr_desc(ntr)) + +! ! Set the inflow values of the dyes, one per segment. +! ! We know the order: north, south, east, west + do m=1,ntr + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m + tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + + do n=1,OBC%number_of_segments + if (n == m) then + dye = 1.0 + else + dye = 0.0 + endif + call register_segment_tracer(tr_desc(m), param_file, GV, & + OBC%segment(n), OBC_scalar=dye) + enddo + enddo + deallocate(tr_desc) + +end subroutine dyed_channel_set_OBC_tracer_data + +!> This subroutine updates the long-channel flow +subroutine dyed_channel_update_flow(OBC, CS, G, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(dyed_channel_OBC_CS), pointer :: CS !< tidal bay control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< model time. + +! Local variables + character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. + character(len=80) :: name, longname + real :: flow, time_sec, PI + integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n + integer :: IsdB, IedB, JsdB, JedB + type(OBC_segment_type), pointer :: segment + + if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & + 'dyed_channel_update_flow() was called but OBC type was not initialized!') + + time_sec = time_type_to_real(Time) + PI = 4.0*atan(1.0) do l=1, OBC%number_of_segments segment => OBC%segment(l) @@ -65,18 +158,23 @@ subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) if (segment%is_E_or_W) then jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + if (CS%frequency == 0.0) then + flow = CS%zonal_flow + else + flow = CS%zonal_flow * cos(2 * PI * CS%frequency * time_sec) + endif do k=1,G%ke do j=jsd,jed ; do I=IsdB,IedB if (segment%specified .or. segment%nudged) then - segment%normal_vel(I,j,k) = zonal_flow + segment%normal_vel(I,j,k) = flow endif if (segment%specified) then - segment%normal_trans(I,j,k) = zonal_flow * G%dyCu(I,j) + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) endif enddo ; enddo enddo do j=jsd,jed ; do I=IsdB,IedB - segment%normal_vel_bt(I,j) = zonal_flow + segment%normal_vel_bt(I,j) = flow enddo ; enddo else isd = segment%HI%isd ; ied = segment%HI%ied @@ -87,37 +185,7 @@ subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) endif enddo - call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & - "The number of dye tracers in this run. Each tracer \n"//& - "should have a separate boundary segment.", default=0, & - do_not_log=.true.) - - if (OBC%number_of_segments .lt. ntr) then - call MOM_error(WARNING, "Error in dyed_obc segment setup") - return !!! Need a better error message here - endif - allocate(tr_desc(ntr)) - -! ! Set the inflow values of the dyes, one per segment. -! ! We know the order: north, south, east, west - do m=1,ntr - write(name,'("dye_",I1.1)') m - write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m - tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) - - do n=1,OBC%number_of_segments - if (n == m) then - dye = 1.0 - else - dye = 0.0 - endif - call register_segment_tracer(tr_desc(m), param_file, GV, & - OBC%segment(n), OBC_scalar=dye) - enddo - enddo - deallocate(tr_desc) - -end subroutine dyed_channel_set_OBC_data +end subroutine dyed_channel_update_flow !> \namespace dyed_channel_initialization !! Setting dyes, one for painting the inflow on each side. diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 8e490890d1..b608395a3f 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -64,8 +64,8 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) ! ! Set the inflow values of the dyes, one per segment. ! ! We know the order: north, south, east, west do m=1,ntr - write(name,'("dye_",I1.1)') m - write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) do n=1,OBC%number_of_segments diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 5e1aaaa576..a0d1850ecb 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -132,7 +132,7 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, h, Time) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness. type(time_type), intent(in) :: Time !< model time. - ! The following variables are used to set up the transport in the tidal_bay example. + ! The following variables are used to set up the transport in the shelfwave example. real :: my_amp, time_sec real :: cos_wt, cos_ky, sin_wt, sin_ky, omega, alpha real :: x, y, jj, kk, ll From 742e9a152f236606d933197760d7f0c8517a6a27 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 4 Dec 2017 08:26:40 -0800 Subject: [PATCH 032/170] Assign a default tolerance if none specified for unit testing --- src/ALE/.f2py_f2cmap | 1 + src/tracer/MOM_neutral_diffusion.F90 | 23 ++++++++++++++--------- 2 files changed, 15 insertions(+), 9 deletions(-) create mode 100644 src/ALE/.f2py_f2cmap diff --git a/src/ALE/.f2py_f2cmap b/src/ALE/.f2py_f2cmap new file mode 100644 index 0000000000..0967ef424b --- /dev/null +++ b/src/ALE/.f2py_f2cmap @@ -0,0 +1 @@ +{} diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 4ff3c55062..5f9218a8c4 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1282,7 +1282,7 @@ end subroutine find_neutral_surface_positions_continuous subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, & Pres_l, hcol_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & PoL, PoR, KoL, KoR, hEff, & - refine_pos_in, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r, EOS, max_iter, tolerance, ref_pres) + refine_pos_in, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r, EOS, max_iter, tol_in, ref_pres) integer, intent(in) :: nk !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial used for reconstructions @@ -1314,7 +1314,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, real, dimension(nk,deg+1), optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction type(EOS_type), optional, pointer :: EOS !< Equation of state structure integer, optional, intent(in) :: max_iter !< Maximum number of iterations in refine_position - real, optional, intent(in) :: tolerance !< Convergence criterion for refine_position + real, optional, intent(in) :: tol_in !< Convergence criterion for refine_position real, optional, intent(in) :: ref_pres !< Reference pressure to use for deriviative calculation ! Local variables @@ -1329,7 +1329,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, real :: dRho, dRhoTop, dRhoBot, dRhoTopm1, hL, hR integer :: lastK_left, lastK_right real :: lastP_left, lastP_right - real :: min_bound + real :: min_bound, tolerance logical, dimension(nk) :: top_connected_l, top_connected_r logical, dimension(nk) :: bot_connected_l, bot_connected_r @@ -1345,11 +1345,12 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, refine_pos = refine_pos_in if (refine_pos .and. (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. & present(ppoly_T_r) .and. present(ppoly_S_r) .and. & - present(tolerance) .and. present(max_iter) .and. present(ref_pres) ) )) & + present(tol_in) .and. present(max_iter) .and. present(ref_pres) ) )) & call MOM_error(FATAL, "fine_neutral_surface_positions_discontinuous: refine_pos is requested, but polynomial"// & "coefficients not available for T and S") endif - + tolerance = 0. + if (present(tol_in)) tolerance = tol_in do k = 1,nk if (stable_l(k)) then kl_left = k @@ -1792,6 +1793,10 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K T_right_top = ( 1. - PiR(k_sublayer) ) * Tir(krt) + PiR(k_sublayer) * Tir(krt+1) T_right_layer = ppm_ave(PiR(k_sublayer), PiR(k_sublayer+1) + real(krb-krt), & aL_r(krt), aR_r(krt), Tr(krt)) + dT_top = T_right_top - T_left_top + dT_bottom = T_right_bottom - T_left_bottom + dT_ave = 0.5 * ( dT_top + dT_bottom ) + dT_layer = T_right_layer - T_left_layer else ! Discontinuous reconstruction klb = KoL(k_sublayer+1) klt = KoL(k_sublayer) @@ -1815,11 +1820,11 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K T_right_top = evaluation_polynomial( ppoly_r_coeffs_r(krt,:), deg+1, PiR(k_sublayer)) T_right_layer = average_value_ppoly(nk, Tr, Tid_r, ppoly_r_coeffs_r, iMethod, krb, & PiR(k_sublayer), PiR(k_sublayer+1)) + dT_top = T_right_top - T_left_top + dT_bottom = T_right_bottom - T_left_bottom + dT_layer = T_right_layer - T_left_layer + dT_ave = dT_layer endif - dT_top = T_right_top - T_left_top - dT_bottom = T_right_bottom - T_left_bottom - dT_ave = 0.5 * ( dT_top + dT_bottom ) - dT_layer = T_right_layer - T_left_layer if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then dT_ave = 0. else From 86ef6877b77ffe16897e2377c18dbe3fc3ad8262 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 4 Dec 2017 15:08:29 -0500 Subject: [PATCH 033/170] Accidentally added a temporary file --- src/ALE/.f2py_f2cmap | 1 - 1 file changed, 1 deletion(-) delete mode 100644 src/ALE/.f2py_f2cmap diff --git a/src/ALE/.f2py_f2cmap b/src/ALE/.f2py_f2cmap deleted file mode 100644 index 0967ef424b..0000000000 --- a/src/ALE/.f2py_f2cmap +++ /dev/null @@ -1 +0,0 @@ -{} From 8d82440b02ed37b41625f9e652007ee3a1179382 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 4 Dec 2017 12:00:20 -0900 Subject: [PATCH 034/170] Comment out unneeded exchange in OBC. - Exchange is not needed because we set OBC values in halos. - Also added check for nz==1 in vertical diffusion. --- src/core/MOM_dynamics_split_RK2.F90 | 7 ++++--- src/tracer/MOM_tracer_diabatic.F90 | 8 +++++++- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 1ef72e238c..72f4b7c178 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -569,10 +569,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call cpu_clock_end(id_clock_continuity) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") + call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (associated(CS%OBC)) then - ! These should be done with a pass that excludes uh & vh. - call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) @@ -581,9 +580,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) & call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) + + ! These should be done with a pass that excludes uh & vh. +! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) endif - call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (G%nonblocking_updates) then call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) endif diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 4a88d7f2e3..02f44e44dd 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -65,6 +65,12 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (nz == 1) then + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, tracer_vertdiff called "//& + "with only one vertical level") + return + endif + if (present(convert_flux_in)) convert_flux = convert_flux_in h_neglect = GV%H_subroundoff sink_dist = 0.0 @@ -413,7 +419,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim do i = 1, min(numberOfGroundings, maxGroundings) write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & G%geoLatT( iGround(i), jGround(i)) , hGrounding(i) - call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, applyTracerBoundaryFluxesInOut(): "//& "Tracer created. x,y,dh= "//trim(mesg), all_print=.true.) enddo From a39077ebd0daa9e1fc7940c60913db9122f9781f Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 5 Dec 2017 10:46:24 -0500 Subject: [PATCH 035/170] Updates to tolerance logic --- src/tracer/MOM_neutral_diffusion.F90 | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 5f9218a8c4..731fa88da1 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1607,14 +1607,20 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, if (kl > kl_0) then ! Away from top cell if (kl == lastK) then ! Searching in the same layer if (dRhoTop > tolerance) then - out_P = max(0.,lastP) ; out_K = kl - elseif ( ABS(dRhoTop - dRhoBot)= (dRhoBot+tolerance)) then + elseif (dRhoTop >= dRhoBot) then out_P = 1. ; out_K = kl else out_K = kl @@ -1633,14 +1639,20 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, if (ki == 1) then out_P = 0. ; out_K = kl elseif (dRhoTop > tolerance) then - out_P = max(0.,lastP) ; out_K = kl - elseif ( (dRhoTop - dRhoBot)= (dRhoBot+tolerance)) then + elseif (dRhoTop >= dRhoBot) then out_P = 1. ; out_K = kl else out_K = kl From c4db609fc2b63d01311a927765621b35063006e3 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 4 Dec 2017 12:00:20 -0900 Subject: [PATCH 036/170] Comment out unneeded exchange in OBC. - Exchange is not needed because we set OBC values in halos. - Also added check for nz==1 in vertical diffusion. --- src/core/MOM_dynamics_split_RK2.F90 | 7 ++++--- src/tracer/MOM_tracer_diabatic.F90 | 8 +++++++- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 1ef72e238c..72f4b7c178 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -569,10 +569,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call cpu_clock_end(id_clock_continuity) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") + call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (associated(CS%OBC)) then - ! These should be done with a pass that excludes uh & vh. - call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) @@ -581,9 +580,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) & call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) + + ! These should be done with a pass that excludes uh & vh. +! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) endif - call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (G%nonblocking_updates) then call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) endif diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 4a88d7f2e3..02f44e44dd 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -65,6 +65,12 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (nz == 1) then + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, tracer_vertdiff called "//& + "with only one vertical level") + return + endif + if (present(convert_flux_in)) convert_flux = convert_flux_in h_neglect = GV%H_subroundoff sink_dist = 0.0 @@ -413,7 +419,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim do i = 1, min(numberOfGroundings, maxGroundings) write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & G%geoLatT( iGround(i), jGround(i)) , hGrounding(i) - call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, applyTracerBoundaryFluxesInOut(): "//& "Tracer created. x,y,dh= "//trim(mesg), all_print=.true.) enddo From 49b8cfc7a016a60eacb0f8ada681e07a2aec9040 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 5 Dec 2017 16:34:18 -0500 Subject: [PATCH 037/170] Update the tests for making sure that a column is stable --- src/tracer/MOM_neutral_diffusion.F90 | 49 +++++++++-------- src/tracer/MOM_neutral_diffusion_aux.F90 | 68 ++++++++++++------------ 2 files changed, 58 insertions(+), 59 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 731fa88da1..50b250593a 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -405,12 +405,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) endif enddo ; enddo ; enddo - 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( G%ke, CS%dRdT_l(i,j,:), CS%dRdS_l(i,j,:), T(i,j,:), S(i,j,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) - enddo ; enddo - endif - do j = G%jsc-1, G%jec+1 ! Interpolate state to interface do i = G%isc-1, G%iec+1 @@ -448,6 +442,11 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) endif enddo + 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( G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) + enddo ; enddo + endif CS%uhEff(:,:,:) = 0. CS%vhEff(:,:,:) = 0. @@ -2137,7 +2136,6 @@ logical function ndiff_unit_tests_discontinuous(verbose) logical :: v v = verbose - ndiff_unit_tests_discontinuous = .false. ! Normally return false write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' @@ -2152,10 +2150,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) do k = 1,nk ; Pres_l(k+1) = Pres_l(k) + hL(k) ; Pres_r(k+1) = Pres_r(k) + hR(k) ; enddo ! Identical columns Tl = (/20.,16.,12./) ; Tr = (/20.,16.,12./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) @@ -2167,10 +2165,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns') Tl = (/20.,16.,12./) ; Tr = (/18.,14.,10./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2181,10 +2179,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column slightly cooler') Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) ; - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2195,10 +2193,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Left column slightly cooler') Tl = (/20.,16.,12./) ; Tr = (/14.,10.,6./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2209,10 +2207,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column somewhat cooler') Tl = (/20.,16.,12./) ; Tr = (/8.,6.,4./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2223,10 +2221,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column much cooler') Tl = (/14.,14.,10./) ; Tr = (/14.,14.,10./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2237,10 +2235,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns with mixed layer') Tl = (/20.,16.,12./) ; Tr = (/14.,14.,10./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2251,10 +2249,11 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column with mixed layer') Tl = (/14.,14.,6./) ; Tr = (/12.,16.,8./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) + print *, stable_l, stable_r call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 10, KoL, KoR, PoL, PoR, hEff, & @@ -2268,8 +2267,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) Tl = (/10.,11.,6./) ; Tr = (/12.,13.,8./) Til(:,1) = (/8.,12.,10./) ; Til(:,2) = (/12.,10.,2./) Tir(:,1) = (/10.,14.,12./) ; TiR(:,2) = (/14.,12.,4./) - call mark_unstable_cells( nk, dRdT, dRdS, Tl, Sl, stable_l, ns_l ) - call mark_unstable_cells( nk, dRdT, dRdS, Tr, Sr, stable_r, ns_r ) + call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) + call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 8, KoL, KoR, PoL, PoR, hEff, & diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 74f0129b94..e8d98a200d 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -20,52 +20,52 @@ module MOM_neutral_diffusion_aux !> Given the reconsturcitons of dRdT, dRdS, T, S mark the cells which are stably stratified parts of the water column !! For an layer to be unstable the top interface must be denser than the bottom or the bottom interface of the layer -!! subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) integer, intent(in) :: nk !< Number of levels in a column - real, dimension(nk), intent(in) :: dRdT !< drho/dT (kg/m3/degC) - real, dimension(nk), intent(in) :: dRdS !< drho/dS (kg/m3/ppt) - real, dimension(nk), intent(in) :: T !< drho/dS (kg/m3/ppt) - real, dimension(nk), intent(in) :: S !< drho/dS (kg/m3/ppt) + real, dimension(nk,2), intent(in) :: dRdT !< drho/dT (kg/m3/degC) at interfaces + real, dimension(nk,2), intent(in) :: dRdS !< drho/dS (kg/m3/ppt) at interfaces + real, dimension(nk,2), intent(in) :: T !< drho/dS (kg/m3/ppt) at interfaces + real, dimension(nk,2), intent(in) :: S !< drho/dS (kg/m3/ppt) at interfaces logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified integer, intent( out) :: ns !< Number of neutral surfaces in unmasked part of the column integer :: k, first_stable, prev_stable real :: delta_rho - ns = 0 - ! If only one cell, then we really shouldn't do anything - if (nk==1) then - stable_cell(nk)=.true. - ns = 2 - return - endif - first_stable = 1 - prev_stable = 1 - ! First sweep down and find the first place where the column is stable - do k=1,nk-1 - delta_rho = ( (dRdT(k) + dRdT(k+1))*(T(k)-T(k+1)) ) + ( (dRdS(k) + dRdS(k+1))*(S(k)-S(k+1)) ) - if (delta_rho <= 0.) then - first_stable = k+1 - prev_stable = k - stable_cell(k) = .true. - ns = ns + 2 + ! First check to make sure that density profile between the two interfaces of the cell are stable + ! Note that we neglect a factor of 0.5 because we only care about the sign of delta_rho not magnitude + do k = 1,nk + ! Compare density of bottom interface to top interface, should be positive (or zero) if stable + delta_rho = (dRdT(k,2) + dRdT(k,1))*(T(k,2) - T(k,1)) + (dRdS(k,2) + dRdS(k,1))*(S(k,2) - S(k,1)) + stable_cell(k) = delta_rho >= 0. + enddo + + ! Check to see that bottom interface of upper cell is lighter than the upper interface of the lower cell + do k=1,nk + if (stable_cell(k)) then + first_stable = k exit - else - stable_cell(k) = .false. endif enddo + prev_stable = first_stable + + ! Start either with the first stable cell or the layer just below the surface + do k = prev_stable+1, nk + ! Don't do anything if the cell has already been marked as unstable + if (.not. stable_cell(k)) cycle + ! Otherwise, we need to check to see if this cell's upper interface is denser than the previous stable_cell + ! Compare top interface of lower cell to bottom interface of upper cell, positive or zero if bottom cell is stable + delta_rho = (dRdT(k,1) + dRdT(prev_stable,2))*(T(k,1) - T(prev_stable,2)) + & + (dRdS(k,1) + dRdS(prev_stable,2))*(S(k,1) - S(prev_stable,2)) + stable_cell(k) = delta_rho >= 0. + ! If the lower cell is marked as stable, then it should be the next reference cell + if (stable_cell(k)) prev_stable = k + enddo - ! Loop through the rest of the column - do k=first_stable,nk - delta_rho = ( (dRdT(prev_stable) + dRdT(k))*(T(prev_stable)-T(k)) ) + ( (dRdS(prev_stable) + dRdS(k))*(S(prev_stable)-S(k)) ) - if (delta_rho <= 0.) then - stable_cell(k) = .true. - prev_stable = k - ns = ns + 2 - else - stable_cell(k) = .false. - endif + ! Number of interfaces is the 2 times number of stable cells in the water column + ns = 0 + do k = 1,nk + if (stable_cell(k)) ns = ns + 2 enddo end subroutine mark_unstable_cells From 42890767febc4efac834479b6f3001aaddee225a Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 5 Dec 2017 17:43:54 -0500 Subject: [PATCH 038/170] Pare down some unused code and try to shorten it --- src/tracer/MOM_neutral_diffusion.F90 | 260 ++------------------------- src/tracer/MOM_tracer_hor_diff.F90 | 40 +---- 2 files changed, 22 insertions(+), 278 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 50b250593a..eb1ccf8e64 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -30,7 +30,6 @@ module MOM_neutral_diffusion #include public neutral_diffusion -public neutral_diffusion_comp public neutral_diffusion_init public neutral_diffusion_diag_init public neutral_diffusion_end @@ -669,196 +668,6 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) end subroutine neutral_diffusion -!> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. -subroutine neutral_diffusion_comp(G, GV, h, Coef_x, Coef_y, T, S, T_idx, S_idx, dt, CS) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H units) - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points (m^2) - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at u-points (m^2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T !< Temperature - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: S !< Salinity - integer, intent(in) :: T_idx !< Index of temperature tracer - integer, intent(in) :: S_idx !< Index of temperature tracer - real, intent(in) :: dt !< Tracer time step * I_numitts (I_numitts in tracer_hordiff) - type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure - - ! Local variables - real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer (concentration * H) - real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer (concentration * H) - real, dimension(SZI_(G),SZJ_(G),G%ke) :: T_tendency ! tendency array for diagn - real, dimension(SZI_(G),SZJ_(G)) :: T_tendency_2d ! depth integrated content tendency for diagn - real, dimension(SZIB_(G),SZJ_(G)) :: T_trans_x_2d ! depth integrated diffusive tracer x-transport diagn - real, dimension(SZI_(G),SZJB_(G)) :: T_trans_y_2d ! depth integrated diffusive tracer y-transport diagn - real, dimension(SZI_(G),SZJ_(G),G%ke) :: S_tendency ! tendency array for diagn - real, dimension(SZI_(G),SZJ_(G)) :: S_tendency_2d ! depth integrated content tendency for diagn - real, dimension(SZIB_(G),SZJ_(G)) :: S_trans_x_2d ! depth integrated diffusive tracer x-transport diagn - real, dimension(SZI_(G),SZJB_(G)) :: S_trans_y_2d ! depth integrated diffusive tracer y-transport diagn - real, dimension(G%ke) :: dS ! change in tracer concentration due to ndiffusion - real, dimension(G%ke) :: dTemp ! change in tracer concentration due to ndiffusion - real, dimension(G%ke) :: dRdT ! change in tracer concentration due to ndiffusion - real, dimension(G%ke) :: dRdS ! change in tracer concentration due to ndiffusion - integer :: i, j, k, ks, nk - real :: ppt2mks, Idt, T_convert, S_convert - - nk = GV%ke - - ! for diagnostics - if(CS%id_neutral_diff_tracer_conc_tend(T_idx) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend(T_idx) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend_2d(T_idx) > 0 .or. & - CS%id_neutral_diff_tracer_trans_x_2d(T_idx) > 0 .or. & - CS%id_neutral_diff_tracer_trans_y_2d(T_idx) > 0) then - Idt = 1.0/dt - T_tendency(:,:,:) = 0.0 - T_tendency_2d(:,:) = 0.0 - T_trans_x_2d(:,:) = 0.0 - T_trans_y_2d(:,:) = 0.0 - T_convert = CS%C_p * GV%H_to_kg_m2 - endif - if(CS%id_neutral_diff_tracer_conc_tend(S_idx) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend(S_idx) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend_2d(S_idx) > 0 .or. & - CS%id_neutral_diff_tracer_trans_x_2d(S_idx) > 0 .or. & - CS%id_neutral_diff_tracer_trans_y_2d(S_idx) > 0) then - ppt2mks = 0.001 - Idt = 1.0/dt - S_tendency(:,:,:) = 0.0 - S_tendency_2d(:,:) = 0.0 - S_trans_x_2d(:,:) = 0.0 - S_trans_y_2d(:,:) = 0.0 - S_convert = ppt2mks * GV%H_to_kg_m2 - endif - - uFlx(:,:,:) = 0. - vFlx(:,:,:) = 0. - - ! First calculate fluxes of salt - ! x-flux - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i+1,j,:), & - S(i,j,:), S(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), & - CS%uKoL(I,j,:), CS%uKoR(I,j,:), & - CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, CS%remap_CS) - endif - enddo ; enddo - - ! y-flux - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i,j+1,:), & - S(i,j,:), S(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), & - CS%vKoL(i,J,:), CS%vKoR(i,J,:), & - CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, CS%remap_CS) - endif - enddo ; enddo - - ! Update the tracer concentration from divergence of neutral diffusive flux components - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - - dS(:) = 0. - do ks = 1,CS%nsurf-1 ; - k = CS%uKoL(I,j,ks) - dS(k) = dS(k) + Coef_x(I,j) * uFlx(I,j,ks) - k = CS%uKoR(I-1,j,ks) - dS(k) = dS(k) - Coef_x(I-1,j) * uFlx(I-1,j,ks) - k = CS%vKoL(i,J,ks) - dS(k) = dS(k) + Coef_y(i,J) * vFlx(i,J,ks) - k = CS%vKoR(i,J-1,ks) - dS(k) = dS(k) - Coef_y(i,J-1) * vFlx(i,J-1,ks) - enddo - do k = 1, GV%ke - S(i,j,k) = S(i,j,k) + dS(k) * & - ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) - dTemp(k) = dS(k) * (CS%dRdS_l(i,j,k)/CS%dRdT_l(i,j,k)) - T(i,j,k) = T(i,j,k) + dTemp(k) * & - ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) - enddo - -! Update to appropriately calculate T flux -! if(CS%id_neutral_diff_tracer_conc_tend(S_idx) > 0 .or. & -! CS%id_neutral_diff_tracer_cont_tend(S_idx) > 0 .or. & -! CS%id_neutral_diff_tracer_cont_tend_2d(S_idx) > 0 ) then -! do k = 1, GV%ke -! S_tendency(i,j,k) = dS(k) * G%IareaT(i,j) * Idt -! enddo -! endif -! if(CS%id_neutral_diff_tracer_conc_tend(T_idx) > 0 .or. & -! CS%id_neutral_diff_tracer_cont_tend(T_idx) > 0 .or. & -! CS%id_neutral_diff_tracer_cont_tend_2d(T_idx) > 0 ) then -! do k = 1, GV%ke -! T_tendency(i,j,k) = dT(k) * G%IareaT(i,j) * Idt -! enddo -! endif - - endif - enddo ; enddo - -! Need to update this so that the T fluxes are calculated correctly -! ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. -! ! Note sign corresponds to downgradient flux convention. -! if(CS%id_neutral_diff_tracer_trans_x_2d(m) > 0) then -! do j = G%jsc,G%jec ; do I = G%isc-1,G%iec -! trans_x_2d(I,j) = 0. -! if (G%mask2dCu(I,j)>0.) then -! do ks = 1,CS%nsurf-1 ; -! trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) -! enddo -! trans_x_2d(I,j) = trans_x_2d(I,j) * Idt * convert -! endif -! enddo ; enddo -! call post_data(CS%id_neutral_diff_tracer_trans_x_2d(m), trans_x_2d(:,:), CS%diag) -! endif -! -! ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. -! ! Note sign corresponds to downgradient flux convention. -! if(CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then -! do J = G%jsc-1,G%jec ; do i = G%isc,G%iec -! trans_y_2d(i,J) = 0. -! if (G%mask2dCv(i,J)>0.) then -! do ks = 1,CS%nsurf-1 ; -! trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) -! enddo -! trans_y_2d(i,J) = trans_y_2d(i,J) * Idt * convert -! endif -! enddo ; enddo -! call post_data(CS%id_neutral_diff_tracer_trans_y_2d(m), trans_y_2d(:,:), CS%diag) -! endif -! -! ! post tendency of tracer content -! if(CS%id_neutral_diff_tracer_cont_tend(m) > 0) then -! call post_data(CS%id_neutral_diff_tracer_cont_tend(m), tendency(:,:,:)*convert, CS%diag) -! endif - -! ! post depth summed tendency for tracer content -! if(CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0) then -! 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(CS%id_neutral_diff_tracer_cont_tend_2d(m), tendency_2d(:,:)*convert, 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(CS%id_neutral_diff_tracer_conc_tend(m) > 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(CS%id_neutral_diff_tracer_conc_tend(m), tendency, CS%diag) -! endif - - -end subroutine neutral_diffusion_comp - !> Returns interface scalar, Si, for a column of layer values, S. subroutine interface_scalar(nk, h, S, Si, i_method) integer, intent(in) :: nk !< Number of levels @@ -1324,8 +1133,9 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, 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 :: refine_pos ! Use rootfinding to find the true neutral surface position + logical :: search_layer integer :: k, kl_left_0, kl_right_0 - real :: dRho, dRhoTop, dRhoBot, dRhoTopm1, hL, hR + real :: dRho, dRhoTop, dRhoBot, hL, hR integer :: lastK_left, lastK_right real :: lastP_left, lastP_right real :: min_bound, tolerance @@ -1410,18 +1220,9 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, dRhoBot = 0.5 * & ( ( dRdT_l(kl_left,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left,2) - Tr(kl_right,ki_right) ) & + ( dRdS_l(kl_left,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left,2) - Sr(kl_right,ki_right) ) ) - if (lastK_left /= kl_left .and. kl_left>kl_left_0) then - if (stable_l(kl_left-1) ) then ! Calculate the density difference at top of discontinuity - dRhoTopm1 = 0.5 * & - ( ( dRdT_l(kl_left-1,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left-1,2) - Tr(kl_right,ki_right) ) & - + ( dRdS_l(kl_left-1,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left-1,2) - Sr(kl_right,ki_right) ) ) - endif - else - dRhoTopm1 = dRhoTop - endif if (debug_this_module) then - write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching left layer ", kl_left, ": dRhoTopm1=", dRhoTopm1, & - " dRhoTop=", dRhoTop, " dRhoBot=", dRhoBot + write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching left layer ", kl_left, & + " dRhoTop=", dRhoTop, " dRhoBot=", dRhoBot write(*,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right write(*,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) write(*,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) @@ -1433,10 +1234,10 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, KoR(k_surface) = kl_right ! Set position within the searched column - call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & + call search_other_column_discontinuous(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & lastP_left, lastK_left, kl_left, kl_left_0, ki_left, tolerance, top_connected_l, bot_connected_l, & - PoL(k_surface), KoL(k_surface)) - if ( refine_pos .and. (PoL(k_surface) > 0.) .and. (PoL(k_surface) < 1.) ) then + PoL(k_surface), KoL(k_surface), search_layer) + if ( refine_pos .and. search_layer ) then min_bound = 0. if (k_surface > 1) then if ( KoL(k_surface) == KoL(k_surface-1) ) min_bound = PoL(k_surface-1) @@ -1449,7 +1250,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, if (PoL(k_surface) == 0.) top_connected_l(KoL(k_surface)) = .true. if (PoL(k_surface) == 1.) bot_connected_l(KoL(k_surface)) = .true. call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, searching_right_column, searching_left_column) - lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) elseif (searching_right_column) then ! Interpolate for the neutral surface position within the right column, layer krm1 @@ -1460,17 +1260,8 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, dRhoBot = 0.5 * & ( ( dRdT_r(kl_right,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,2) - Tl(kl_left,ki_left) ) & + ( dRdS_r(kl_right,2) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,2) - Sl(kl_left,ki_left) ) ) - if (lastK_right /= kl_right .and. kl_right>kl_right_0) then - if(stable_r(kl_right-1)) then - dRhoTopm1 = 0.5 * & - ( ( dRdT_r(kl_right-1,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right-1,2) - Tl(kl_left,ki_left) ) & - + ( dRdS_r(kl_right-1,2) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right-1,2) - Sl(kl_left,ki_left) ) ) - endif - else - dRhoTopm1 = dRhoTop - endif if (debug_this_module) then - write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching right layer ", kl_right, ": dRhoTopm1=", dRhoTopm1, & + write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching right layer ", kl_right, & " dRhoTop=", dRhoTop, " dRhoBot=", dRhoBot write(*,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left write(*,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) @@ -1482,10 +1273,10 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, KoL(k_surface) = kl_left ! Set position within the searched column - call search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), & + call search_other_column_discontinuous(dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), & lastP_right, lastK_right, kl_right, kl_right_0, ki_right, tolerance, top_connected_r, bot_connected_r, & - PoR(k_surface), KoR(k_surface)) - if ( refine_pos .and. (PoR(k_surface) > 0. .and. PoR(k_surface) < 1.) ) then + PoR(k_surface), KoR(k_surface), search_layer) + if ( refine_pos .and. search_layer) then min_bound = 0. if (k_surface > 1) then if ( KoR(k_surface) == KoR(k_surface-1) ) min_bound = PoR(k_surface-1) @@ -1498,7 +1289,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, if (PoR(k_surface) == 0.) top_connected_r(KoR(k_surface)) = .true. if (PoR(k_surface) == 1.) bot_connected_r(KoR(k_surface)) = .true. call increment_interface(nk, kl_left, ki_left, stable_l, reached_bottom, searching_left_column, searching_right_column) - lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) else stop 'Else what?' @@ -1527,23 +1317,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, endif endif enddo neutral_surfaces - ! Check to make sure that neutral surfaces are truly neutral - if (debug_this_module) then - do k_surface = 1,ns-1 - if (hEff(k_surface)>0.) then - kl_left = KoL(k_surface) - kl_right = KoR(k_surface) - if (refine_pos) then - if ( check_neutral_positions(deg, EOS, & - PoL(k_surface), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), (/Pres_l(kl_left),Pres_l(kl_left+1)/), & - PoR(k_surface), ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), (/Pres_r(kl_right),Pres_r(kl_right+1)/),& - tolerance, ref_pres) ) then - call MOM_error(WARNING,"Endpoints of neutral surfaces have different densities") - endif - endif - endif - enddo - endif end subroutine find_neutral_surface_positions_discontinuous @@ -1580,14 +1353,11 @@ subroutine increment_interface(nk, kl, ki, stable, reached_bottom, searching_thi else call MOM_error(FATAL,"Unanticipated eventuality in increment_interface") endif - - end subroutine increment_interface !> Searches the "other" (searched) column for the position of the neutral surface -subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, kl_0, ki, & - tolerance, top_connected, bot_connected, out_P, out_K) - real, intent(in ) :: dRhoTopm1 !< Density difference across previous interface +subroutine search_other_column_discontinuous(dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, kl_0, ki, & + tolerance, top_connected, bot_connected, out_P, out_K, search_layer) real, intent(in ) :: dRhoTop !< Density difference across top interface real, intent(in ) :: dRhoBot !< Density difference across top interface real, intent(in ) :: Ptop !< Pressure at top interface @@ -1602,7 +1372,9 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, logical, dimension(:), intent(inout) :: bot_connected !< True if the top interface was pointed to real, intent( out) :: out_P !< Position within searched column integer, intent( out) :: out_K !< Layer within searched column + logical, intent( out) :: search_layer !< Neutral surface within cell + search_layer = .false. if (kl > kl_0) then ! Away from top cell if (kl == lastK) then ! Searching in the same layer if (dRhoTop > tolerance) then @@ -1624,6 +1396,7 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, else out_K = kl out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) + search_layer = .true. endif else ! Searching across the interface if (.not. bot_connected(kl-1) ) then @@ -1656,6 +1429,7 @@ subroutine search_other_column_discontinuous(dRhoTopm1, dRhoTop, dRhoBot, Ptop, else out_K = kl out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) + search_layer = .true. endif endif diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 6e08165820..6477fd4aab 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -21,7 +21,7 @@ module MOM_tracer_hor_diff use MOM_MEKE_types, only : MEKE_type 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, neutral_diffusion_comp +use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion 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 @@ -52,10 +52,6 @@ module MOM_tracer_hor_diff ! limit is not violated. logical :: use_neutral_diffusion ! If true, use the neutral_diffusion module from within ! tracer_hor_diff. - logical :: ndiff_comp_flux ! If true, neutral diffusion uses Prescription B of Griffies et al. 1998, where - ! the temperature flux is calculated from the salinity flux to ensure no change in - ! locally referenced potential density due to diffusion - type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() ! Control structure for neutral diffusion. type(diag_ctrl), pointer :: diag ! structure to regulate timing of diagnostic output. logical :: debug ! If true, write verbose checksums for debugging purposes. @@ -353,28 +349,10 @@ 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 - if (CS%ndiff_comp_flux) then - ! Find index of T and S tracers - T_idx = -1 ; S_idx = -1 - do m=1,ntr - if (trim(Reg%tr(m)%name) == "T") T_idx = m - if (trim(Reg%tr(m)%name) == "S") S_idx = m - enddo - if ((T_idx < 0) .or. (S_idx < 0)) call MOM_error(FATAL, "Neutral diffusion: NDIFF_COMP_FLUX = .true." // & - "requires both T and S to be registered") - call neutral_diffusion_comp(G, GV, h, Coef_x, Coef_y, Reg%Tr(T_idx)%t, Reg%Tr(S_idx)%t, T_idx, S_idx, I_numitts*dt, & - CS%neutral_diffusion_CSp) - do m = 1,ntr - if ( (m == T_idx) .or. (m == S_idx) ) cycle - call neutral_diffusion(G, GV, h, Coef_x, Coef_y, Reg%Tr(m)%t, m, I_numitts*dt, & - Reg%Tr(m)%name, CS%neutral_diffusion_CSp) - enddo - else - do m=1,ntr ! for each tracer - call neutral_diffusion(G, GV, h, Coef_x, Coef_y, Reg%Tr(m)%t, m, I_numitts*dt, & - Reg%Tr(m)%name, CS%neutral_diffusion_CSp) - enddo ! m - endif + do m=1,ntr ! for each tracer + call neutral_diffusion(G, GV, h, Coef_x, Coef_y, Reg%Tr(m)%t, m, I_numitts*dt, & + Reg%Tr(m)%name, CS%neutral_diffusion_CSp) + enddo enddo ! itt else ! following if not using neutral diffusion, but instead along-surface diffusion @@ -1398,8 +1376,6 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, CS, CSnd) units="nondim", default=0.5) call get_param(param_file, mdl, "DT", CS%dt, fail_if_missing=.true., & desc="The (baroclinic) dynamics time step.", units="s") - - call get_param(param_file, mdl, "DIFFUSE_ML_TO_INTERIOR", CS%Diffuse_ML_interior, & "If true, enable epipycnal mixing between the surface \n"//& "boundary layer and the interior.", default=.false.) @@ -1418,12 +1394,6 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, CS, CSnd) CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, CS%neutral_diffusion_CSp) CSnd => CS%neutral_diffusion_CSp - if (CS%use_neutral_diffusion) then - call get_param(param_file, "MOM_neutral_diffusion", "NDIFF_COMP_FLUX", CS%ndiff_comp_flux, & - "If true, use Prescription B of Griffies et al. (1998) \n" // & - "to calculate the temperature flux from the salinity \n" // & - "flux to ensure that density does not change", default = .false.) - endif 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!") From 55d692b0765c5319b6f1ef34e85a94625c95300d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 6 Dec 2017 13:14:47 -0500 Subject: [PATCH 039/170] (*)Corrected chksum routines to work with rescaling Made substantial corrections to the coding of the various chksum routines so that the will do the rescaling before determining statistics (like the global mean). Before, these could lead to differences when there is extreme rescaling (e.g. by 2^-93) due to the fixed-point representation of the global sums. In addition, the fact that there is now a rescaled array to look at should be helpful for use with debuggers. All answers are bitwise identical. --- src/framework/MOM_checksums.F90 | 191 ++++++++++++++++++++++++++------ 1 file changed, 155 insertions(+), 36 deletions(-) diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index db30152620..16e0802d4a 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -115,7 +115,9 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: i, j integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners @@ -128,7 +130,18 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) endif scaling = 1.0 ; if (present(scale)) scaling = scale - if (calculateStatistics) call subStats(HI, array, mesg, scaling) + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + rescaled_array(i,j) = scale*array(i,j) + enddo ; enddo + call subStats(HI, rescaled_array, mesg) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg) + endif ; endif if (.not.writeChksums) return @@ -186,11 +199,11 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, scale) + subroutine subStats(HI, array, mesg) type(hor_index_type), intent(in) :: HI real, dimension(HI%isd:,HI%jsd:), intent(in) :: array character(len=*), intent(in) :: mesg - real, intent(in) :: scale + integer :: i, j, n real :: aMean, aMin, aMax @@ -207,7 +220,7 @@ subroutine subStats(HI, array, mesg, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("h-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("h-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_h_2d @@ -274,7 +287,9 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: i, j, Is, Js integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -286,10 +301,23 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif scaling = 1.0 ; if (present(scale)) scaling = scale - sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) call subStats(HI, array, mesg, sym_stats, scaling) + + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do J=Js,HI%JecB ; do I=Is,HI%IecB + rescaled_array(I,J) = scale*array(I,J) + enddo ; enddo + call subStats(HI, rescaled_array, mesg, sym_stats) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg, sym_stats) + endif ; endif if (.not.writeChksums) return @@ -356,12 +384,12 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, sym_stats, scale) + subroutine subStats(HI, array, mesg, sym_stats) type(hor_index_type), intent(in) :: HI real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array character(len=*), intent(in) :: mesg logical, intent(in) :: sym_stats - real, intent(in) :: scale + integer :: i, j, n, IsB, JsB real :: aMean, aMin, aMax @@ -380,7 +408,7 @@ subroutine subStats(HI, array, mesg, sym_stats, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("B-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("B-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_B_2d @@ -437,7 +465,9 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: i, j, Is integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -452,7 +482,20 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) call subStats(HI, array, mesg, sym_stats, scaling) + + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + do j=HI%jsc,HI%jec ; do I=Is,HI%IecB + rescaled_array(I,j) = scale*array(I,j) + enddo ; enddo + call subStats(HI, rescaled_array, mesg, sym_stats) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg, sym_stats) + endif ; endif if (.not.writeChksums) return @@ -525,12 +568,12 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, sym_stats, scale) + subroutine subStats(HI, array, mesg, sym_stats) type(hor_index_type), intent(in) :: HI real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array character(len=*), intent(in) :: mesg logical, intent(in) :: sym_stats - real, intent(in) :: scale + integer :: i, j, n, IsB real :: aMean, aMin, aMax @@ -548,7 +591,7 @@ subroutine subStats(HI, array, mesg, sym_stats, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("u-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("u-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_u_2d @@ -565,7 +608,9 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:) :: rescaled_array real :: scaling + integer :: i, j, Js integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -580,7 +625,20 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) call subStats(HI, array, mesg, sym_stats, scaling) + + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2)) ) + rescaled_array(:,:) = 0.0 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do J=Js,HI%JecB ; do i=HI%isc,HI%iec + rescaled_array(i,J) = scale*array(i,J) + enddo ; enddo + call subStats(HI, rescaled_array, mesg, sym_stats) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg, sym_stats) + endif ; endif if (.not.writeChksums) return @@ -653,12 +711,12 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, sym_stats, scale) + subroutine subStats(HI, array, mesg, sym_stats) type(hor_index_type), intent(in) :: HI real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array character(len=*), intent(in) :: mesg logical, intent(in) :: sym_stats - real, intent(in) :: scale + integer :: i, j, n, JsB real :: aMean, aMin, aMax @@ -676,7 +734,7 @@ subroutine subStats(HI, array, mesg, sym_stats, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("v-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("v-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_v_2d @@ -692,7 +750,9 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: i, j, k integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners @@ -705,7 +765,20 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) endif scaling = 1.0 ; if (present(scale)) scaling = scale - if (calculateStatistics) call subStats(HI, array, mesg, scaling) + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + rescaled_array(i,j,k) = scale*array(i,j,k) + enddo ; enddo ; enddo + + call subStats(HI, rescaled_array, mesg) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg) + endif ; endif if (.not.writeChksums) return @@ -763,11 +836,11 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, scale) + subroutine subStats(HI, array, mesg) type(hor_index_type), intent(in) :: HI real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array character(len=*), intent(in) :: mesg - real, intent(in) :: scale + integer :: i, j, k, n real :: aMean, aMin, aMax @@ -784,7 +857,7 @@ subroutine subStats(HI, array, mesg, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("h-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("h-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_h_3d @@ -801,7 +874,9 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: i, j, k, Is, Js integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -813,10 +888,24 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif scaling = 1.0 ; if (present(scale)) scaling = scale - sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) call subStats(HI, array, mesg, sym_stats, scaling) + + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB + rescaled_array(I,J,k) = scale*array(I,J,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, mesg, sym_stats) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg, sym_stats) + endif ; endif if (.not.writeChksums) return @@ -888,12 +977,12 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, sym_stats, scale) + subroutine subStats(HI, array, mesg, sym_stats) type(hor_index_type), intent(in) :: HI real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array character(len=*), intent(in) :: mesg logical, intent(in) :: sym_stats - real, intent(in) :: scale + integer :: i, j, k, n, IsB, JsB real :: aMean, aMin, aMax @@ -911,7 +1000,7 @@ subroutine subStats(HI, array, mesg, sym_stats, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("B-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("B-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_B_3d @@ -928,7 +1017,9 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: i, j, k, Is integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -940,10 +1031,23 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif scaling = 1.0 ; if (present(scale)) scaling = scale - sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) call subStats(HI, array, mesg, sym_stats, scaling) + + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do I=Is,HI%IecB + rescaled_array(I,j,k) = scale*array(I,j,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, mesg, sym_stats) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg, sym_stats) + endif ; endif if (.not.writeChksums) return @@ -1016,12 +1120,12 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, sym_stats, scale) + subroutine subStats(HI, array, mesg, sym_stats) type(hor_index_type), intent(in) :: HI real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array character(len=*), intent(in) :: mesg logical, intent(in) :: sym_stats - real, intent(in) :: scale + integer :: i, j, k, n, IsB real :: aMean, aMin, aMax @@ -1039,7 +1143,7 @@ subroutine subStats(HI, array, mesg, sym_stats, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("u-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("u-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_u_3d @@ -1056,7 +1160,9 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. + real, allocatable, dimension(:,:,:) :: rescaled_array real :: scaling + integer :: i, j, k, Js integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1068,10 +1174,23 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif scaling = 1.0 ; if (present(scale)) scaling = scale - sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif - if (calculateStatistics) call subStats(HI, array, mesg, sym_stats, scaling) + + if (calculateStatistics) then ; if (present(scale)) then + allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & + LBOUND(array,2):UBOUND(array,2), & + LBOUND(array,3):UBOUND(array,3)) ) + rescaled_array(:,:,:) = 0.0 + Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 + do k=1,size(array,3) ; do J=Js,HI%JecB ; do i=HI%isc,HI%iec + rescaled_array(i,J,k) = scale*array(i,J,k) + enddo ; enddo ; enddo + call subStats(HI, rescaled_array, mesg, sym_stats) + deallocate(rescaled_array) + else + call subStats(HI, array, mesg, sym_stats) + endif ; endif if (.not.writeChksums) return @@ -1144,12 +1263,12 @@ integer function subchk(array, HI, di, dj, scale) subchk=mod(subchk,1000000000) end function subchk - subroutine subStats(HI, array, mesg, sym_stats, scale) + subroutine subStats(HI, array, mesg, sym_stats) type(hor_index_type), intent(in) :: HI real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array character(len=*), intent(in) :: mesg logical, intent(in) :: sym_stats - real, intent(in) :: scale + integer :: i, j, k, n, JsB real :: aMean, aMin, aMax @@ -1167,7 +1286,7 @@ subroutine subStats(HI, array, mesg, sym_stats, scale) call min_across_PEs(aMin) call max_across_PEs(aMax) aMean = aMean / real(n) - if (is_root_pe()) call chk_sum_msg("v-point:",aMean*scale,aMin*scale,aMax*scale,mesg) + if (is_root_pe()) call chk_sum_msg("v-point:",aMean,aMin,aMax,mesg) end subroutine subStats end subroutine chksum_v_3d From 8a20e911bd3464d9b92f63bf45c61b364cdc7c59 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 6 Dec 2017 13:15:18 -0500 Subject: [PATCH 040/170] (*)Fixed mixedlayer_restart_general with H rescaling Corrected the unit conversions inside of mixedlayer_restart_general so that it now gives identical answers when H is rescaled. This change can change answers when H_TO_M is not 1, but by default all test cases are bitwise identical. --- .../lateral/MOM_mixed_layer_restrat.F90 | 40 ++++++++++--------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 0d7756a278..840a0c3373 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -111,17 +111,17 @@ end subroutine mixedlayer_restrat !> Calculates a restratifying flow in the mixed layer. subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, CS) ! Arguments - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (H units = m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux (m3 or kg) - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (H units = m or kg/m2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux (m3 or kg) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux (m3 or kg) + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< Time increment (sec) - real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by PBL scheme (H units) - type(VarMix_CS), pointer :: VarMix !< Container for derived fields - type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure + real, intent(in) :: dt !< Time increment (sec) + real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by PBL scheme, in m (not H) + type(VarMix_CS), pointer :: VarMix !< Container for derived fields + type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport (m3/s or kg/s) real :: vhml(SZI_(G),SZJB_(G),SZK_(G)) ! merid mixed layer transport (m3/s or kg/s) @@ -164,7 +164,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! arrays for diagnostic purposes. real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK, dK, dKm1, pRef_MLD ! Used for MLD + real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK + real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers, in H. + real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer densities, in Pa. real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 real :: aFac, bFac, ddRho real :: hAtVel, zpa, zpb, dh, res_scaling_fac, I_l_f @@ -191,13 +193,13 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA pRef_MLD(:) = 0. do j = js-1, je+1 - dK(:) = 0.5 * h(:,j,1) * GV%H_to_m ! Depth of center of surface layer + dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is-1, ie-is+3, tv%eqn_of_state) deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. do k = 2, nz dKm1(:) = dK(:) ! Depth of center of layer K-1 - dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) * GV%H_to_m ! Depth of center of layer K + dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K ! Mixed-layer depth, using sigma-0 (surface reference pressure) deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, is-1, ie-is+3, tv%eqn_of_state) @@ -220,7 +222,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (.not. associated(MLD_in)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "Argument MLD_in was not associated!") do j = js-1, je+1 ; do i = is-1, ie+1 - MLD_fast(i,j) = CS%MLE_MLD_stretch * MLD_in(i,j) + MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%m_to_H) * MLD_in(i,j) enddo ; enddo else call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & @@ -230,7 +232,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! Apply time filter (to remove diurnal cycle) if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered,'mixed_layer_restrat: MLD_filtered',G%HI,haloshift=1) + call hchksum(CS%MLD_filtered,'mixed_layer_restrat: MLD_filtered',G%HI,haloshift=1,scale=GV%H_to_m) call hchksum(MLD_in,'mixed_layer_restrat: MLD in',G%HI,haloshift=1) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) @@ -247,8 +249,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! Apply slower time filter (to remove seasonal cycle) on already filtered MLD_fast if (CS%MLE_MLD_decay_time2>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered_slow,'mixed_layer_restrat: MLD_filtered_slow',G%HI,haloshift=1) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD fast',G%HI,haloshift=1) + call hchksum(CS%MLD_filtered_slow,'mixed_layer_restrat: MLD_filtered_slow',G%HI,haloshift=1,scale=GV%H_to_m) + call hchksum(MLD_fast,'mixed_layer_restrat: MLD fast',G%HI,haloshift=1,scale=GV%H_to_m) endif aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) @@ -330,9 +332,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var enddo if (CS%debug) then - call hchksum(h,'mixed_layer_restrat: h',G%HI,haloshift=1) + call hchksum(h,'mixed_layer_restrat: h',G%HI,haloshift=1,scale=GV%H_to_m) call hchksum(forces%ustar,'mixed_layer_restrat: u*',G%HI,haloshift=1) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD',G%HI,haloshift=1) + call hchksum(MLD_fast,'mixed_layer_restrat: MLD',G%HI,haloshift=1,scale=GV%H_to_m) call hchksum(Rml_av_fast,'mixed_layer_restrat: rml',G%HI,haloshift=1) endif From 9b547f3c942b0a904c2d339d0df4c17c40b68972 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 6 Dec 2017 13:15:46 -0500 Subject: [PATCH 041/170] (*)Fixed regularize_layers with H rescaling Corrected the unit conversions inside of find_deficit_ratios in regularize_layers so that it now gives identical answers when H is rescaled. This change can change answers when H_TO_M is not 1, but by default all test cases are bitwise identical. --- .../vertical/MOM_regularize_layers.F90 | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 8e4ccb1377..a95c52ff14 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -839,6 +839,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & h_def2_v real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected, in H. + real :: Hmix_min ! CS%Hmix_min converted to units of H. real :: h1, h2 ! Temporary thicknesses, in H. integer :: i, j, k, is, ie, js, je, nz, nkmb @@ -848,6 +849,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & endif nkmb = GV%nk_rho_varies h_neglect = GV%H_subroundoff + Hmix_min = CS%Hmix_min * GV%m_to_H ! Determine which zonal faces are problematic. do j=js,je ; do I=is-1,ie @@ -890,12 +892,12 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & enddo ; enddo ; enddo if (present(def_rat_u_2lay)) then ; do j=js,je ; do I=is-1,ie def_rat_u(I,j) = G%mask2dCu(I,j) * h_def_u(I,j) / & - (max(CS%Hmix_min, h_norm_u(I,j)) + h_neglect) + (max(Hmix_min, h_norm_u(I,j)) + h_neglect) def_rat_u_2lay(I,j) = G%mask2dCu(I,j) * h_def2_u(I,j) / & - (max(CS%Hmix_min, h_norm_u(I,j)) + h_neglect) + (max(Hmix_min, h_norm_u(I,j)) + h_neglect) enddo ; enddo ; else ; do j=js,je ; do I=is-1,ie def_rat_u(I,j) = G%mask2dCu(I,j) * h_def_u(I,j) / & - (max(CS%Hmix_min, h_norm_u(I,j)) + h_neglect) + (max(Hmix_min, h_norm_u(I,j)) + h_neglect) enddo ; enddo ; endif ! Determine which meridional faces are problematic. @@ -939,12 +941,12 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & enddo ; enddo ; enddo if (present(def_rat_v_2lay)) then ; do J=js-1,je ; do i=is,ie def_rat_v(i,J) = G%mask2dCv(i,J) * h_def_v(i,J) / & - (max(CS%Hmix_min, h_norm_v(i,J)) + h_neglect) + (max(Hmix_min, h_norm_v(i,J)) + h_neglect) def_rat_v_2lay(i,J) = G%mask2dCv(i,J) * h_def2_v(i,J) / & - (max(CS%Hmix_min, h_norm_v(i,J)) + h_neglect) + (max(Hmix_min, h_norm_v(i,J)) + h_neglect) enddo ; enddo ; else ; do J=js-1,je ; do i=is,ie def_rat_v(i,J) = G%mask2dCv(i,J) * h_def_v(i,J) / & - (max(CS%Hmix_min, h_norm_v(i,J)) + h_neglect) + (max(Hmix_min, h_norm_v(i,J)) + h_neglect) enddo ; enddo ; endif end subroutine find_deficit_ratios From 036fa3a14a6b516e7af4ab65ffd2fcddfab2f67c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 6 Dec 2017 13:25:29 -0500 Subject: [PATCH 042/170] Removed trailing white space in 3 lines Removed white space in three lines. All answers are bitwise identical. --- src/framework/MOM_checksums.F90 | 4 ++-- src/parameterizations/vertical/MOM_regularize_layers.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 16e0802d4a..bcf106b881 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -308,7 +308,7 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)) ) rescaled_array(:,:) = 0.0 - Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do J=Js,HI%JecB ; do I=Is,HI%IecB rescaled_array(I,J) = scale*array(I,J) @@ -896,7 +896,7 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)) ) rescaled_array(:,:,:) = 0.0 - Is = HI%isc ; if (sym_stats) Is = HI%isc-1 + Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB rescaled_array(I,J,k) = scale*array(I,J,k) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index a95c52ff14..950c3f5f34 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -839,7 +839,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & h_def2_v real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected, in H. - real :: Hmix_min ! CS%Hmix_min converted to units of H. + real :: Hmix_min ! CS%Hmix_min converted to units of H. real :: h1, h2 ! Temporary thicknesses, in H. integer :: i, j, k, is, ie, js, je, nz, nkmb From 401610d3c6f55dddf3e5c7525a3f0c28cc280424 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 6 Dec 2017 18:53:52 -0500 Subject: [PATCH 043/170] *Refactored convert_thickness Restructured convert_thickness to convert geometric thickesses that have already been converted to units of H into thicknesses in kg/m2, also in H, in non-Boussinesq cases. Because m_to_H in non-Boussiensq cases is not typically an exact power of 2 (it is usually 1/rho0), there is a multiply and divide by a real number, and the initial conditions for non-Boussinesq test cases change at the level of roundoff, even though the two forms are mathematically equivalent. This changes the answers slightly in the nonBous_global test case. --- .../MOM_state_initialization.F90 | 35 +++++++++++-------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index f70ebe9be9..a743664dd6 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -419,10 +419,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "BOUSSINESQ is defined. This does not apply if a restart \n"//& "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) if (new_sim) then - if (convert .and. .not.GV%Boussinesq) then - ! Convert h from m to kg m-2 then to thickness units (H) - call convert_thickness(h, G, GV, tv) - elseif (GV%Boussinesq) then + if (GV%Boussinesq .or. convert) then ! Convert h from m to thickness units (H) do k=1,nz ; do j=js,je ; do i=is,ie h(i,j,k) = h(i,j,k)*GV%m_to_H @@ -432,6 +429,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & h(i,j,k) = h(i,j,k)*GV%kg_m2_to_H enddo ; enddo ; enddo endif + + if (convert .and. .not.GV%Boussinesq) & + ! Convert thicknesses from geomtric distances to mass-per-unit-area. + call convert_thickness(h, G, GV, tv) endif ! Remove the mass that would be displaced by an ice shelf or inverse barometer. @@ -907,14 +908,14 @@ end subroutine initialize_thickness_search ! ----------------------------------------------------------------------------- subroutine convert_thickness(h, G, GV, tv) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + 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(SZI_(G),SZJ_(G), SZK_(G)), & - intent(inout) :: h !< Layer thicknesses, being - !! converted from m to H (m or kg - !! m-2) - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables + intent(inout) :: h !< Input eometric layer thicknesses (in H units), + !! being converted to layer pressure + !! thicknesses (also in H units). + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables ! Arguments: h - The thickness that is being initialized. ! (in) G - The ocean's grid structure. ! (in) GV - The ocean's vertical grid structure. @@ -924,6 +925,8 @@ subroutine convert_thickness(h, G, GV, tv) ! across a layer, in m2 s-2. real :: rho(SZI_(G)) real :: I_gEarth + real :: Hm_rho_to_Pa ! A conversion factor from the input geometric thicknesses + ! times the layer densities into Pa, in Pa m3 / H kg. logical :: Boussinesq integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: itt, max_itt @@ -933,6 +936,7 @@ subroutine convert_thickness(h, G, GV, tv) max_itt = 10 Boussinesq = GV%Boussinesq I_gEarth = 1.0 / GV%g_Earth + Hm_rho_to_Pa = (GV%g_Earth * GV%H_to_m) ! = GV%H_to_Pa / GV%Rho0 if (Boussinesq) then call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") @@ -947,7 +951,7 @@ subroutine convert_thickness(h, G, GV, tv) call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & is, ie-is+1, tv%eqn_of_state) do i=is,ie - p_bot(i,j) = p_top(i,j) + GV%g_Earth * h(i,j,k) * rho(i) + p_bot(i,j) = p_top(i,j) + Hm_rho_to_Pa * (h(i,j,k) * rho(i)) enddo enddo @@ -961,7 +965,8 @@ subroutine convert_thickness(h, G, GV, tv) ! The hydrostatic equation is linear to such a ! high degree that no bounds-checking is needed. do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * (GV%g_Earth*h(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + rho(i) * & + (Hm_rho_to_Pa*h(i,j,k) - dz_geo(i,j)) enddo enddo ; endif enddo @@ -972,7 +977,9 @@ subroutine convert_thickness(h, G, GV, tv) enddo else do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k) * GV%Rlay(k) * GV%kg_m2_to_H + h(i,j,k) = (h(i,j,k) * GV%Rlay(k)) * Hm_rho_to_Pa + ! This is mathematically equivalent to + ! h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) enddo ; enddo ; enddo endif endif From f21d1303b0e2fd22566aced6ca66c68d6ec217d4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 6 Dec 2017 18:58:08 -0500 Subject: [PATCH 044/170] Removed trailing white space in one line --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index a743664dd6..56e49a3fc9 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -978,7 +978,7 @@ subroutine convert_thickness(h, G, GV, tv) else do k=1,nz ; do j=js,je ; do i=is,ie h(i,j,k) = (h(i,j,k) * GV%Rlay(k)) * Hm_rho_to_Pa - ! This is mathematically equivalent to + ! This is mathematically equivalent to ! h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) enddo ; enddo ; enddo endif From df4d0d6b7936b4da639409ce20208df4f4e3561b Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 7 Dec 2017 15:04:19 -0500 Subject: [PATCH 045/170] Add an option to allow for boundary extrapolation in remapping routines --- src/ALE/MOM_ALE.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 84664f45a8..6cbfb050c0 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -150,6 +150,7 @@ subroutine ALE_init( param_file, GV, max_depth, CS) logical :: check_remapping logical :: force_bounds_in_subcell logical :: local_logical + logical :: remap_boundary_extrap if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -216,8 +217,11 @@ subroutine ALE_init( param_file, GV, max_depth, CS) "If true, the values on the intermediate grid used for remapping\n"//& "are forced to be bounded, which might not be the case due to\n"//& "round off.", default=.false.) + call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & + "If true, values at the interfaces of boundary cells are \n"//& + "extrapolated instead of piecewise constant", default=.false.) call initialize_remapping( CS%remapCS, string, & - boundary_extrapolation=.false., & + boundary_extrapolation=remap_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell) From 0b9e84997411e6b526870f25f4ff7ca881454fc8 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 7 Dec 2017 15:06:44 -0500 Subject: [PATCH 046/170] More updates to neutral diffusion - Move functions and subroutines to neutral_diffusion_aux.F90 - Collapse some of the terms in find_neutral_surface_positions_discontinuous so that it's a little more readable - Tolerance criterion for Newton method convergence now requires it to be negative or zero to prevent small differences from true neutral direction to block out too much of a cell --- src/tracer/MOM_neutral_diffusion.F90 | 244 ++++++----------------- src/tracer/MOM_neutral_diffusion_aux.F90 | 220 ++++++++++++++++---- 2 files changed, 242 insertions(+), 222 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index eb1ccf8e64..1788bca97a 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -14,8 +14,9 @@ module MOM_neutral_diffusion 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_neutral_diffusion_aux, only : mark_unstable_cells, mark_unstable_cells_i, refine_nondim_position -use MOM_neutral_diffusion_aux, only : calc_delta_rho, check_neutral_positions +use MOM_neutral_diffusion_aux, only : mark_unstable_cells, increment_interface, calc_drho, drho_at_pos +use MOM_neutral_diffusion_aux, only : search_other_column, interpolate_for_nondim_position, refine_nondim_position +use MOM_neutral_diffusion_aux, only : check_neutral_positions, kahan_sum 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 @@ -93,7 +94,7 @@ module MOM_neutral_diffusion #include "version_variable.h" character(len=40) :: mdl = "MOM_neutral_diffusion" ! module name -logical :: debug_this_module = .false. ! If true, verbose output of find neutral position +logical :: debug_this_module = .true. ! If true, verbose output of find neutral position contains @@ -1139,6 +1140,7 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, integer :: lastK_left, lastK_right real :: lastP_left, lastP_right real :: min_bound, tolerance + real :: T_other, S_other, P_other, dRdT_other, dRdS_other logical, dimension(nk) :: top_connected_l, top_connected_r logical, dimension(nk) :: bot_connected_l, bot_connected_r @@ -1211,20 +1213,34 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, endif if (searching_left_column) then + ! delta_rho is referenced to the right interface T, S, and P + if (present(ref_pres)) then + P_other = ref_pres + else + if (ki_right == 1) P_other = Pres_r(kl_right) + if (ki_right == 2) P_other = Pres_r(kl_right+1) + endif + T_other = Tr(kl_right, ki_right) + S_other = Sr(kl_right, ki_right) + dRdT_other = dRdT_r(kl_right, ki_right) + dRdS_other = dRdS_r(kl_right, ki_right) ! Determine differences between right column interface and potentially three different parts of the left ! Potential density difference, rho(kl-1) - rho(kr) (should be negative) - dRhoTop = 0.5 * & - ( ( dRdT_l(kl_left,1) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left,1) - Tr(kl_right,ki_right) ) & - + ( dRdS_l(kl_left,1) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left,1) - Sr(kl_right,ki_right) ) ) + if (refine_pos .and. (lastP_left > 0.) .and. (lastP_left < 1.)) then + call drho_at_pos(T_other, S_other, dRdT_other, dRdS_other, deg, Pres_l(kl_left), Pres_l(kl_left+1), & + ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), lastP_left, P_other, EOS, dRhoTop) + else + dRhoTop = calc_drho(Tl(kl_left,1), Sl(kl_left,1), dRdT_l(kl_left,1), dRdS_l(kl_left,1), T_other, S_other, & + dRdT_other, dRdS_other) + endif ! Potential density difference, rho(kl) - rho(kl_right,ki_right) (will be positive) - dRhoBot = 0.5 * & - ( ( dRdT_l(kl_left,2) + dRdT_r(kl_right,ki_right) ) * ( Tl(kl_left,2) - Tr(kl_right,ki_right) ) & - + ( dRdS_l(kl_left,2) + dRdS_r(kl_right,ki_right) ) * ( Sl(kl_left,2) - Sr(kl_right,ki_right) ) ) + dRhoBot = calc_drho(Tl(kl_left,2), Sl(kl_left,2), dRdT_l(kl_left,2), dRdS_l(kl_left,2), & + T_other, S_other, dRdT_other, dRdS_other) if (debug_this_module) then write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching left layer ", kl_left, & " dRhoTop=", dRhoTop, " dRhoBot=", dRhoBot write(*,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right - write(*,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) + write(*,*) "Temp/Salt Reference: ", T_other, S_other write(*,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) endif @@ -1234,37 +1250,50 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, KoR(k_surface) = kl_right ! Set position within the searched column - call search_other_column_discontinuous(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & - lastP_left, lastK_left, kl_left, kl_left_0, ki_left, tolerance, top_connected_l, bot_connected_l, & - PoL(k_surface), KoL(k_surface), search_layer) + call search_other_column(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), lastP_left, lastK_left, kl_left, & + kl_left_0, ki_left, top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface), & + search_layer) + if ( refine_pos .and. search_layer ) then min_bound = 0. if (k_surface > 1) then if ( KoL(k_surface) == KoL(k_surface-1) ) min_bound = PoL(k_surface-1) endif - PoL(k_surface) = refine_nondim_position(max_iter, tolerance, Tr(kl_right,ki_right), Sr(kl_right,ki_right), & - dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), Pres_l(kl_left), Pres_l(kl_left+1), & - deg, ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), EOS, min_bound, dRhoTop, dRhoBot, min_bound, & - ref_pres) + PoL(k_surface) = refine_nondim_position(max_iter, tolerance, T_other, S_other, dRdT_other, dRdS_other, & + Pres_l(kl_left), Pres_l(kl_left+1), deg, ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), & + EOS, min_bound, dRhoTop, dRhoBot, min_bound, ref_pres) endif if (PoL(k_surface) == 0.) top_connected_l(KoL(k_surface)) = .true. if (PoL(k_surface) == 1.) bot_connected_l(KoL(k_surface)) = .true. call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, searching_right_column, searching_left_column) elseif (searching_right_column) then + if (present(ref_pres)) then + P_other = ref_pres + else + if (ki_left == 1) P_other = Pres_l(kl_left) + if (ki_left == 2) P_other = Pres_l(kl_left+1) + endif + T_other = Tl(kl_left, ki_left) + S_other = Sl(kl_left, ki_left) + dRdT_other = dRdT_l(kl_left, ki_left) + dRdS_other = dRdS_l(kl_left, ki_left) ! 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 * & - ( ( dRdT_r(kl_right,1) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,1) - Tl(kl_left,ki_left) ) & - + ( dRdS_r(kl_right,1) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,1) - Sl(kl_left,ki_left) ) ) - dRhoBot = 0.5 * & - ( ( dRdT_r(kl_right,2) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,2) - Tl(kl_left,ki_left) ) & - + ( dRdS_r(kl_right,2) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,2) - Sl(kl_left,ki_left) ) ) + if (refine_pos .and. (lastP_right > 0.) .and. (lastP_right<1.)) then + call drho_at_pos(T_other, S_other, dRdT_other, dRdS_other,deg, Pres_r(kl_right), Pres_l(kl_right+1), & + ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), lastP_right, P_other, EOS, dRhoTop) + else + dRhoTop = calc_drho(Tr(kl_right,1), Sr(kl_right,1), dRdT_r(kl_right,1), dRdS_r(kl_right,1), & + T_other, S_other, dRdT_other, dRdS_other) + endif + dRhoBot = calc_drho(Tr(kl_right,2), Sr(kl_right,2), dRdT_r(kl_right,2), dRdS_r(kl_right,2), & + T_other, S_other, dRdT_other, dRdS_other) if (debug_this_module) then write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching right layer ", kl_right, & " dRhoTop=", dRhoTop, " dRhoBot=", dRhoBot write(*,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left - write(*,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) + write(*,*) "Temp/Salt Reference: ", T_other, S_other write(*,*) "Temp/Salt Top R: ", Tr(kl_right,1), Sr(kl_right,1) write(*,*) "Temp/Salt Bot R: ", Tr(kl_right,2), Sr(kl_right,2) endif @@ -1273,18 +1302,17 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, KoL(k_surface) = kl_left ! Set position within the searched column - call search_other_column_discontinuous(dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), & - lastP_right, lastK_right, kl_right, kl_right_0, ki_right, tolerance, top_connected_r, bot_connected_r, & - PoR(k_surface), KoR(k_surface), search_layer) + call search_other_column(dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), lastP_right, lastK_right, & + kl_right, kl_right_0, ki_right, top_connected_r, bot_connected_r, PoR(k_surface), & + KoR(k_surface), search_layer) if ( refine_pos .and. search_layer) then min_bound = 0. if (k_surface > 1) then if ( KoR(k_surface) == KoR(k_surface-1) ) min_bound = PoR(k_surface-1) endif - PoR(k_surface) = refine_nondim_position(max_iter, tolerance, Tl(kl_left,ki_left), Sl(kl_left,ki_left), & - dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), Pres_r(kl_right), Pres_r(kl_right+1), & - deg, ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), EOS, min_bound, dRhoTop, dRhoBot, min_bound, & - ref_pres) + PoR(k_surface) = refine_nondim_position(max_iter, tolerance, T_other, S_other, dRdT_other, dRdS_other, & + Pres_r(kl_right), Pres_r(kl_right+1), deg, ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), & + EOS, min_bound, dRhoTop, dRhoBot, min_bound, ref_pres) endif if (PoR(k_surface) == 0.) top_connected_r(KoR(k_surface)) = .true. if (PoR(k_surface) == 1.) bot_connected_r(KoR(k_surface)) = .true. @@ -1320,120 +1348,6 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, end subroutine find_neutral_surface_positions_discontinuous -!> Increments the interface which was just connected and also set flags if the bottom is reached -subroutine increment_interface(nk, kl, ki, stable, reached_bottom, searching_this_column, searching_other_column) - integer, intent(in ) :: nk !< Number of vertical levels - integer, intent(inout) :: kl !< Current layer (potentially updated) - integer, intent(inout) :: ki !< Current interface - logical, dimension(nk), intent(in ) :: stable !< True if the cell is stably stratified - logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 - logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 - logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 - integer :: k - - if (ki == 1) then - ki = 2 - elseif ((ki == 2) .and. (kl < nk) ) then - do k = kl+1,nk - if (stable(kl)) then - kl = k - ki = 1 - exit - endif - ! If we did not find another stable cell, then the current cell is essentially the bottom - ki = 2 - reached_bottom = .true. - searching_this_column = .true. - searching_other_column = .false. - enddo - elseif ((kl == nk) .and. (ki==2)) then - reached_bottom = .true. - searching_this_column = .true. - searching_other_column = .false. - else - call MOM_error(FATAL,"Unanticipated eventuality in increment_interface") - endif -end subroutine increment_interface - -!> Searches the "other" (searched) column for the position of the neutral surface -subroutine search_other_column_discontinuous(dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, kl_0, ki, & - tolerance, top_connected, bot_connected, out_P, out_K, search_layer) - real, intent(in ) :: dRhoTop !< Density difference across top interface - real, intent(in ) :: dRhoBot !< Density difference across top interface - real, intent(in ) :: Ptop !< Pressure at top interface - real, intent(in ) :: Pbot !< Pressure at bottom interface - real, intent(in ) :: lastP !< Last position connected in the searched column - integer, intent(in ) :: lastK !< Last layer connected in the searched column - integer, intent(in ) :: kl !< Layer in the searched column - integer, intent(in ) :: kl_0 !< Layer in the searched column - integer, intent(in ) :: ki !< Interface of the searched column - real, intent(in ) :: tolerance !< How close to 0 "neutral" is defined - logical, dimension(:), intent(inout) :: top_connected !< True if the top interface was pointed to - logical, dimension(:), intent(inout) :: bot_connected !< True if the top interface was pointed to - real, intent( out) :: out_P !< Position within searched column - integer, intent( out) :: out_K !< Layer within searched column - logical, intent( out) :: search_layer !< Neutral surface within cell - - search_layer = .false. - if (kl > kl_0) then ! Away from top cell - if (kl == lastK) then ! Searching in the same layer - if (dRhoTop > tolerance) then - if (lastK == kl) then - out_P = lastP - else - out_P = 0. - endif - out_K = kl -! out_P = max(0.,lastP) ; out_K = kl - elseif ( dRhoTop == dRhoBot ) then - if (top_connected(kl)) then - out_P = 1. ; out_K = kl - else - out_P = max(0.,lastP) ; out_K = kl - endif - elseif (dRhoTop >= dRhoBot) then - out_P = 1. ; out_K = kl - else - out_K = kl - out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) - search_layer = .true. - endif - else ! Searching across the interface - if (.not. bot_connected(kl-1) ) then - out_K = kl-1 - out_P = 1. - else - out_K = kl - out_P = 0. - endif - endif - else ! At the top cell - if (ki == 1) then - out_P = 0. ; out_K = kl - elseif (dRhoTop > tolerance) then - if (lastK == kl) then - out_P = lastP - else - out_P = 0. - endif - out_K = kl -! out_P = max(0.,lastP) ; out_K = kl - elseif ( dRhoTop == dRhoBot ) then - if (top_connected(kl)) then - out_P = 1. ; out_K = kl - else - out_P = max(0.,lastP) ; out_K = kl - endif - elseif (dRhoTop >= dRhoBot) then - out_P = 1. ; out_K = kl - else - out_K = kl - out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) - search_layer = .true. - endif - endif - -end subroutine search_other_column_discontinuous !> Converts non-dimensional position within a layer to absolute position (for debugging) real function absolute_position(n,ns,Pint,Karr,NParr,k_surface) integer, intent(in) :: n !< Number of levels @@ -1470,41 +1384,6 @@ function absolute_positions(n,ns,Pint,Karr,NParr) end function absolute_positions -!> Returns the non-dimensional position between Pneg and Ppos where the -!! interpolated density difference equals zero. -!! The result is always bounded to be between 0 and 1. -real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) - real, intent(in) :: dRhoNeg !< Negative density difference - real, intent(in) :: Pneg !< Position of negative density difference - real, intent(in) :: dRhoPos !< Positive density difference - real, intent(in) :: Ppos !< Position of positive density difference - - if (PposdRhoPos) then - write(0,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos - elseif (dRhoNeg>dRhoPos) then - stop 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos' - endif - if (Ppos<=Pneg) then ! Handle vanished or inverted layers - interpolate_for_nondim_position = 0.5 - elseif ( dRhoPos - dRhoNeg > 0. ) then - interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) - elseif ( dRhoPos - dRhoNeg == 0) then - if (dRhoNeg>0.) then - interpolate_for_nondim_position = 0. - elseif (dRhoNeg<0.) then - interpolate_for_nondim_position = 1. - else ! dRhoPos = dRhoNeg = 0 - interpolate_for_nondim_position = 0.5 - endif - else ! dRhoPos - dRhoNeg < 0 - interpolate_for_nondim_position = 0.5 - endif - if ( interpolate_for_nondim_position < 0. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg' - if ( interpolate_for_nondim_position > 1. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' -end function interpolate_for_nondim_position - !> Returns a single column of neutral diffusion fluxes of a tracer. subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, hEff, Flx, continuous, remap_CS) integer, intent(in) :: nk !< Number of levels @@ -1582,6 +1461,11 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K dT_bottom = T_right_bottom - T_left_bottom dT_ave = 0.5 * ( dT_top + dT_bottom ) dT_layer = T_right_layer - T_left_layer + if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then + dT_ave = 0. + else + dT_ave = dT_layer + endif else ! Discontinuous reconstruction klb = KoL(k_sublayer+1) klt = KoL(k_sublayer) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index e8d98a200d..803e714ad7 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -10,8 +10,11 @@ module MOM_neutral_diffusion_aux implicit none ; private public mark_unstable_cells -public mark_unstable_cells_i -public calc_delta_rho +public increment_interface +public calc_drho +public drho_at_pos +public search_other_column +public interpolate_for_nondim_position public refine_nondim_position public check_neutral_positions public kahan_sum @@ -70,47 +73,64 @@ subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) end subroutine mark_unstable_cells -subroutine mark_unstable_cells_i(nk, dRdT, dRdS,T, S, stable_cell, ns) - integer, intent(in) :: nk !< Number of levels in a column - real, dimension(nk,2), intent(in) :: dRdT !< drho/dT (kg/m3/degC) - real, dimension(nk,2), intent(in) :: dRdS !< drho/dS (kg/m3/ppt) - real, dimension(nk,2), intent(in) :: T !< drho/dS (kg/m3/ppt) - real, dimension(nk,2), intent(in) :: S !< drho/dS (kg/m3/ppt) - logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified - integer, intent( out) :: ns !< Number of neutral surfaces in unmasked part of the column - - integer :: k, first_stable, prev_stable - real :: delta_rho - - ! If only one cell, then we really shouldn't do anything - if (nk==1) then - stable_cell(nk)=.true. - ns = 2 - return - endif - - do k=1,nk - ! Only check cell which are stable - if (stable_cell(k)) then - delta_rho = ( (dRdT(k,1) + dRdT(k,2))*(T(k,1)-T(k,2)) ) + ( (dRdS(k,1) + dRdS(k,2))*(S(k,1)-S(k,2)) ) - if (delta_rho > 0.) then - stable_cell(k) = .false. - ns = ns - 2 +!> Increments the interface which was just connected and also set flags if the bottom is reached +subroutine increment_interface(nk, kl, ki, stable, reached_bottom, searching_this_column, searching_other_column) + integer, intent(in ) :: nk !< Number of vertical levels + integer, intent(inout) :: kl !< Current layer (potentially updated) + integer, intent(inout) :: ki !< Current interface + logical, dimension(nk), intent(in ) :: stable !< True if the cell is stably stratified + logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 + logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 + logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 + integer :: k + + if (ki == 1) then + ki = 2 + elseif ((ki == 2) .and. (kl < nk) ) then + do k = kl+1,nk + if (stable(kl)) then + kl = k + ki = 1 + exit endif - endif - enddo - -end subroutine mark_unstable_cells_i + ! If we did not find another stable cell, then the current cell is essentially the bottom + ki = 2 + reached_bottom = .true. + searching_this_column = .true. + searching_other_column = .false. + enddo + elseif ((kl == nk) .and. (ki==2)) then + reached_bottom = .true. + searching_this_column = .true. + searching_other_column = .false. + else + call MOM_error(FATAL,"Unanticipated eventuality in increment_interface") + endif +end subroutine increment_interface + +!> Calculates difference in density at two points (rho1-rho2) with known density derivatives, T, and S +real function calc_drho(T1, S1, dRdT1, dRdS1, T2, S2, dRdT2, dRdS2) + real, intent(in ) :: T1 !< Temperature at point 1 + real, intent(in ) :: S1 !< Salinity at point 1 + real, intent(in ) :: dRdT1 !< dRhodT at point 1 + real, intent(in ) :: dRdS1 !< dRhodS at point 1 + real, intent(in ) :: T2 !< Temperature at point 2 + real, intent(in ) :: S2 !< Salinity at point 2 + real, intent(in ) :: dRdT2 !< dRhodT at point 2 + real, intent(in ) :: dRdS2 !< dRhodS at point + + calc_drho = 0.5*( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2) ) +end function calc_drho !> Calculate the difference in neutral density between a reference T, S, alpha, and beta !! and a point on the polynomial reconstructions of T, S -subroutine calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, x0, ref_pres, EOS, & +subroutine drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, x0, ref_pres, EOS, & delta_rho, P_out, T_out, S_out, alpha_avg_out, beta_avg_out, delta_T_out, delta_S_out) - integer, intent(in) :: deg !< Degree of polynomial reconstruction real, intent(in) :: T_ref !< Temperature at reference surface real, intent(in) :: S_ref !< Salinity at reference surface real, intent(in) :: alpha_ref !< dRho/dT at reference surface real, intent(in) :: beta_ref !< dRho/dS at reference surface + integer, intent(in) :: deg !< Degree of polynomial reconstruction real, intent(in) :: P_top !< Pressure (Pa) at top interface of layer to be searched real, intent(in) :: P_bot !< Pressure (Pa) at bottom interface real, dimension(deg+1), intent(in) :: ppoly_T !< Coefficients of T reconstruction @@ -156,7 +176,122 @@ subroutine calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, if (present(delta_T_out)) delta_T_out = delta_T if (present(delta_S_out)) delta_S_out = delta_S -end subroutine calc_delta_rho +end subroutine drho_at_pos + +!> Searches the "other" (searched) column for the position of the neutral surface +subroutine search_other_column(dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, kl_0, ki, & + top_connected, bot_connected, out_P, out_K, search_layer) + real, intent(in ) :: dRhoTop !< Density difference across top interface + real, intent(in ) :: dRhoBot !< Density difference across top interface + real, intent(in ) :: Ptop !< Pressure at top interface + real, intent(in ) :: Pbot !< Pressure at bottom interface + real, intent(in ) :: lastP !< Last position connected in the searched column + integer, intent(in ) :: lastK !< Last layer connected in the searched column + integer, intent(in ) :: kl !< Layer in the searched column + integer, intent(in ) :: kl_0 !< Layer in the searched column + integer, intent(in ) :: ki !< Interface of the searched column + logical, dimension(:), intent(inout) :: top_connected !< True if the top interface was pointed to + logical, dimension(:), intent(inout) :: bot_connected !< True if the top interface was pointed to + real, intent( out) :: out_P !< Position within searched column + integer, intent( out) :: out_K !< Layer within searched column + logical, intent( out) :: search_layer !< Neutral surface within cell + + search_layer = .false. + if (kl > kl_0) then ! Away from top cell + if (kl == lastK) then ! Searching in the same layer + if (dRhoTop > 0.) then + if (lastK == kl) then + out_P = lastP + else + out_P = 0. + endif + out_K = kl +! out_P = max(0.,lastP) ; out_K = kl + elseif ( dRhoTop == dRhoBot ) then + if (top_connected(kl)) then + out_P = 1. ; out_K = kl + else + out_P = max(0.,lastP) ; out_K = kl + endif + elseif (dRhoTop >= dRhoBot) then + out_P = 1. ; out_K = kl + else + out_K = kl + out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) + search_layer = .true. + endif + else ! Searching across the interface + if (.not. bot_connected(kl-1) ) then + out_K = kl-1 + out_P = 1. + else + out_K = kl + out_P = 0. + endif + endif + else ! At the top cell + if (ki == 1) then + out_P = 0. ; out_K = kl + elseif (dRhoTop > 0.) then + if (lastK == kl) then + out_P = lastP + else + out_P = 0. + endif + out_K = kl +! out_P = max(0.,lastP) ; out_K = kl + elseif ( dRhoTop == dRhoBot ) then + if (top_connected(kl)) then + out_P = 1. ; out_K = kl + else + out_P = max(0.,lastP) ; out_K = kl + endif + elseif (dRhoTop >= dRhoBot) then + out_P = 1. ; out_K = kl + else + out_K = kl + out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) + search_layer = .true. + endif + endif + +end subroutine search_other_column + +!> Returns the non-dimensional position between Pneg and Ppos where the +!! interpolated density difference equals zero. +!! The result is always bounded to be between 0 and 1. +real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) + real, intent(in) :: dRhoNeg !< Negative density difference + real, intent(in) :: Pneg !< Position of negative density difference + real, intent(in) :: dRhoPos !< Positive density difference + real, intent(in) :: Ppos !< Position of positive density difference + + if (PposdRhoPos) then + write(0,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos + elseif (dRhoNeg>dRhoPos) then + stop 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos' + endif + if (Ppos<=Pneg) then ! Handle vanished or inverted layers + interpolate_for_nondim_position = 0.5 + elseif ( dRhoPos - dRhoNeg > 0. ) then + interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) + elseif ( dRhoPos - dRhoNeg == 0) then + if (dRhoNeg>0.) then + interpolate_for_nondim_position = 0. + elseif (dRhoNeg<0.) then + interpolate_for_nondim_position = 1. + else ! dRhoPos = dRhoNeg = 0 + interpolate_for_nondim_position = 0.5 + endif + else ! dRhoPos - dRhoNeg < 0 + interpolate_for_nondim_position = 0.5 + endif + if ( interpolate_for_nondim_position < 0. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg' + if ( interpolate_for_nondim_position > 1. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' +end function interpolate_for_nondim_position + !> Use root-finding methods to find where dRho = 0, based on the equation of state and the polynomial !! reconstructions of temperature, salinity. Initial guess is based on the zero crossing of based on linear @@ -206,7 +341,7 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re real :: d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep real :: P_last - logical :: debug = .false. + logical :: debug = .true. if (ref_pres>=0.) P_ref = ref_pres delta_P = P_bot-P_top refine_nondim_position = min_bound @@ -220,8 +355,8 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re endif ! Calculate the initial values - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, min_bound, & - ref_pres, EOS, delta_rho, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) + call drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, min_bound, & + ref_pres, EOS, delta_rho, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) delta_rho_init = delta_rho if ( ABS(delta_rho_init) < tolerance ) then refine_nondim_position = min_bound @@ -280,10 +415,11 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re b = 0.5*(a + c) endif endif - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & + call drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, & b, ref_pres, EOS, fb, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) if (debug) print *, "Iteration, b, fb: ", iter, b, fb - if (ABS(fb) <= tolerance .or. ABS(b-b_last) <= tolerance ) then +! if (ABS(fb) <= tolerance .or. ABS(b-b_last) <= tolerance ) then + if( (fb <= 0.) .and. (fb >= -tolerance) ) then refine_nondim_position = P_int/delta_P exit endif @@ -361,7 +497,7 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re else sb = sb - tol end if - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & + call drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, & sb, ref_pres, EOS, fb) if ( ( 0. < fb .and. 0. < fc ) .or. & ( fb <= 0. .and. fc <= 0. ) ) then @@ -414,7 +550,7 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re endif if (debug) then - call calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & + call drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, & refine_nondim_position, ref_pres, EOS, delta_rho) write (*,*) "End delta_rho: ", delta_rho write (*,*) "x0, delta_x: ", x0, refine_nondim_position-x0 From a27394152d1549035c359132a7ad3c6588f3d58f Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 8 Dec 2017 16:06:08 -0500 Subject: [PATCH 047/170] Move shared parameters to neutral_diffusion_aux control structure Many of the arguments being passed to and from various subroutines were parameters set at run-time and never modified after. To cut down the amount of repeated code, these were moved to separate control structure --- src/core/MOM.F90 | 2 +- src/tracer/MOM_neutral_diffusion.F90 | 213 ++++++++++++----------- src/tracer/MOM_neutral_diffusion_aux.F90 | 213 +++++++++++------------ src/tracer/MOM_tracer_hor_diff.F90 | 10 +- 4 files changed, 214 insertions(+), 224 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e42236d97f..2dc9aa7ce9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2185,7 +2185,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo 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%tracer_diff_CSp, CS%neutral_diffusion_CSp) + call tracer_hor_diff_init(Time, G, param_file, diag, CS%tv%eqn_of_state, CS%tracer_diff_CSp, CS%neutral_diffusion_CSp) if (CS%use_ALE_algorithm) & call register_diags_TS_vardec(Time, G%HI, GV, param_file, CS) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 1788bca97a..9f5e086bb5 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -14,9 +14,9 @@ module MOM_neutral_diffusion 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_neutral_diffusion_aux, only : ndiff_aux_CS_type, set_ndiff_aux_params use MOM_neutral_diffusion_aux, only : mark_unstable_cells, increment_interface, calc_drho, drho_at_pos use MOM_neutral_diffusion_aux, only : search_other_column, interpolate_for_nondim_position, refine_nondim_position -use MOM_neutral_diffusion_aux, only : check_neutral_positions, kahan_sum 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 @@ -40,9 +40,8 @@ module MOM_neutral_diffusion type, public :: neutral_diffusion_CS ; private integer :: nkp1 ! Number of interfaces for a column = nk + 1 integer :: nsurf ! Number of neutral surfaces - integer :: ppoly_deg = 2 ! Degree of polynomial used for reconstructions + integer :: deg = 2 ! Degree of polynomial used for reconstructions logical :: continuous_reconstruction = .true. ! True if using continuous PPM reconstruction at interfaces - logical :: boundary_extrap = .true. logical :: refine_position = .false. integer :: max_iter ! Maximum number of iterations if refine_position is defined real :: tolerance ! Convergence criterion representing difference from true neutrality @@ -86,29 +85,35 @@ module MOM_neutral_diffusion integer, allocatable, dimension(:) :: id_neutral_diff_tracer_trans_y_2d ! k-summed ndiff merid tracer transport real :: C_p ! heat capacity of seawater (J kg-1 K-1) - - type(remapping_CS) :: remap_CS + type(EOS_type), pointer :: EOS !< Equation of state parameters + type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers + type(ndiff_aux_CS_type), pointer :: ndiff_aux_CS !< Store parameters for iteratively finding neutral surface end type neutral_diffusion_CS ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_neutral_diffusion" ! module name -logical :: debug_this_module = .true. ! If true, verbose output of find neutral position +logical :: debug_this_module = .false. ! If true, verbose output of find neutral position contains !> Read parameters and allocate control structure for neutral_diffusion module. -logical function neutral_diffusion_init(Time, G, param_file, diag, CS) +logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, 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(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables character(len=256) :: mesg ! Message for error messages. character(len=80) :: string ! Temporary strings + logical :: boundary_extrap + ! For refine_pos + integer :: max_iter + real :: drho_tol, xtol, ref_pres if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -127,7 +132,9 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) endif allocate(CS) + allocate(CS%ndiff_aux_CS) CS%diag => diag + CS%EOS => EOS ! call openParameterBlock(param_file,'NEUTRAL_DIFF') ! Read all relevant parameters and write them to the model log. @@ -144,7 +151,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) default = -1.) ! Initialize and configure remapping if (CS%continuous_reconstruction .eqv. .false.) then - call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", CS%boundary_extrap, & + call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & "Uses a rootfinding approach to find the position of a\n"// & "neutral surface within a layer taking into account the\n"// & "nonlinearity of the equation of state and the\n"// & @@ -155,8 +162,8 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) "for vertical remapping for all variables.\n"//& "It can be one of the following schemes:\n"//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = CS%boundary_extrap ) - call extract_member_remapping_CS(CS%remap_CS, degree=CS%ppoly_deg) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NDIFF_REFINE_POSITION", CS%refine_position, & "Uses a rootfinding approach to find the position of a\n"// & "neutral surface within a layer taking into account the\n"// & @@ -164,15 +171,21 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) "polynomial reconstructions of T/S.", & default=.false.) if (CS%refine_position) then - call get_param(param_file, mdl, "NDIFF_TOLERANCE", CS%tolerance, & + call get_param(param_file, mdl, "NDIFF_DRHO_TOL", drho_tol, & "Sets the convergence criterion for finding the neutral\n"// & "position within a layer in kg m-3.", & default=1.e-10) - call get_param(param_file, mdl, "NDIFF_MAX_ITER", CS%max_iter, & + call get_param(param_file, mdl, "NDIFF_X_TOL", xtol, & + "Sets the convergence criterion for a change in nondim\n"// & + "position within a layer.", & + default=0.) + call get_param(param_file, mdl, "NDIFF_MAX_ITER", max_iter, & "The maximum number of iterations to be done before \n"// & "exiting the iterative loop to find the neutral surface", & default=10) + call set_ndiff_aux_params(CS%ndiff_aux_CS, max_iter = max_iter, drho_tol = drho_tol, xtol = xtol) endif + call set_ndiff_aux_params(CS%ndiff_aux_CS, deg=CS%deg, ref_pres = CS%ref_pres, EOS = EOS) call get_param(param_file, mdl, "NDIFF_DEBUG", debug_this_module, & "Turns on verbose output for discontinuous neutral \n"// & "diffusion routines.", & @@ -193,8 +206,8 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) allocate(CS%S_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%S_i(:,:,:,:) = 0. allocate(CS%dRdT_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%dRdT_i(:,:,:,:) = 0. allocate(CS%dRdS_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%dRdS_i(:,:,:,:) = 0. - allocate(CS%ppoly_coeffs_T(SZI_(G),SZJ_(G),SZK_(G),CS%ppoly_deg+1)) ; CS%ppoly_coeffs_T(:,:,:,:) = 0. - allocate(CS%ppoly_coeffs_S(SZI_(G),SZJ_(G),SZK_(G),CS%ppoly_deg+1)) ; CS%ppoly_coeffs_S(:,:,:,:) = 0. + allocate(CS%ppoly_coeffs_T(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1)) ; CS%ppoly_coeffs_T(:,:,:,:) = 0. + allocate(CS%ppoly_coeffs_S(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1)) ; CS%ppoly_coeffs_S(:,:,:,:) = 0. allocate(CS%ns(SZI_(G),SZJ_(G))) ; CS%ns(:,:) = 0. endif ! T-points @@ -357,13 +370,12 @@ end subroutine neutral_diffusion_diag_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, EOS, CS) +subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H units) 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) - type(EOS_type), pointer :: EOS !< Equation of state structure type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables @@ -399,9 +411,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*GV%H_to_Pa if (CS%ref_pres<=0.) then P_lay = 0.5*(CS%Pint(i,j,k+1) + CS%Pint(i,j,k)) - call calculate_density_derivs(T(i,j,k), S(i,j,k), P_lay, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), EOS) + call calculate_density_derivs(T(i,j,k), S(i,j,k), P_lay, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), CS%EOS) else - call calculate_density_derivs(T(i,j,k), S(i,j,k), CS%ref_pres, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), EOS) + call calculate_density_derivs(T(i,j,k), S(i,j,k), CS%ref_pres, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), CS%EOS) endif enddo ; enddo ; enddo @@ -424,20 +436,20 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) do k = 1, G%ke+1 if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) call calculate_density_derivs(CS%Tint(:,j,k), CS%Sint(:,j,k), ref_pres, & - CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, EOS) + CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS) enddo else ! Discontinuous reconstruction do k = 1, G%ke if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) if (CS%stable_cell(i,j,k)) & call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & - CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, EOS) + CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, CS%EOS) if (CS%ref_pres<0) then ref_pres(:) = CS%Pint(:,j,k+1) endif if (CS%stable_cell(i,j,k)) & call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & - CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, EOS) + CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS) enddo endif enddo @@ -468,14 +480,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) 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,:) ) else - call find_neutral_surface_positions_discontinuous(G%ke, CS%ns(i,j)+ CS%ns(i+1,j), CS%ppoly_deg, & - CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & - CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & - CS%Pint(i+1,j,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), & - CS%dRdT_i(i+1,j,:,:), CS%dRdS_i(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%refine_position, CS%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & - CS%ppoly_coeffs_T(i+1,j,:,:), CS%ppoly_coeffs_S(i+1,j,:,:), EOS, CS%max_iter, CS%tolerance, CS%ref_pres) + call find_neutral_surface_positions_discontinuous(CS, G%ke, CS%ns(i,j)+CS%ns(i+1,j), & + CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & + CS%Pint(i+1,j,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), & + CS%dRdT_i(i+1,j,:,:), CS%dRdS_i(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_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & + CS%ppoly_coeffs_T(i+1,j,:,:), CS%ppoly_coeffs_S(i+1,j,:,:)) endif endif enddo ; enddo @@ -489,14 +501,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) 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,:) ) else - call find_neutral_surface_positions_discontinuous(G%ke, CS%ns(i,j)+CS%ns(i,j+1), CS%ppoly_deg, & - CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & - CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & - CS%Pint(i,j+1,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), & - CS%dRdT_i(i,j+1,:,:), CS%dRdS_i(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%refine_position, CS%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & - CS%ppoly_coeffs_T(i,j+1,:,:), CS%ppoly_coeffs_S(i,j+1,:,:), EOS, CS%max_iter, CS%tolerance, CS%ref_pres) + call find_neutral_surface_positions_discontinuous(CS, G%ke, CS%ns(i,j)+CS%ns(i,j+1), & + CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%stable_cell(i,j,:), & + CS%Pint(i,j+1,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), & + CS%dRdT_i(i,j+1,:,:), CS%dRdS_i(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%ppoly_coeffs_T(i,j,:,:), CS%ppoly_coeffs_S(i,j,:,:), & + CS%ppoly_coeffs_T(i,j+1,:,:), CS%ppoly_coeffs_S(i,j+1,:,:)) endif endif @@ -558,7 +570,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) ! x-flux do j = G%jsc,G%jec ; do I = G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i+1,j,:), & + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & Tracer(i,j,:), Tracer(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), & CS%uKoL(I,j,:), CS%uKoR(I,j,:), & @@ -570,7 +582,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) ! y-flux do J = G%jsc-1,G%jec ; do i = G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i,j+1,:), & + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & Tracer(i,j,:), Tracer(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), & CS%vKoL(i,J,:), CS%vKoR(i,J,:), & @@ -1088,13 +1100,12 @@ end subroutine find_neutral_surface_positions_continuous !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S -subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, & - Pres_l, hcol_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & - PoL, PoR, KoL, KoR, hEff, & - refine_pos_in, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r, EOS, max_iter, tol_in, ref_pres) +subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, & + Pres_l, hcol_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & + PoL, PoR, KoL, KoR, hEff, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r) + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces - integer, intent(in) :: deg !< Degree of polynomial used for reconstructions real, dimension(nk+1), intent(in) :: Pres_l !< Left-column interface pressure (Pa) real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature (degC) @@ -1116,15 +1127,10 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, 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) - logical, optional, intent(in) :: refine_pos_in !< True if rootfinding is used for position - real, dimension(nk,deg+1), optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction - real, dimension(nk,deg+1), optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction - real, dimension(nk,deg+1), optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction - real, dimension(nk,deg+1), optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction - type(EOS_type), optional, pointer :: EOS !< Equation of state structure - integer, optional, intent(in) :: max_iter !< Maximum number of iterations in refine_position - real, optional, intent(in) :: tol_in !< Convergence criterion for refine_position - real, optional, intent(in) :: ref_pres !< Reference pressure to use for deriviative calculation + real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction + real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction + real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction + real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction ! Local variables integer :: k_surface ! Index of neutral surface @@ -1133,35 +1139,25 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, 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 - logical :: refine_pos ! Use rootfinding to find the true neutral surface position logical :: search_layer integer :: k, kl_left_0, kl_right_0 real :: dRho, dRhoTop, dRhoBot, hL, hR integer :: lastK_left, lastK_right real :: lastP_left, lastP_right - real :: min_bound, tolerance + real :: min_bound real :: T_other, S_other, P_other, dRdT_other, dRdS_other logical, dimension(nk) :: top_connected_l, top_connected_r logical, dimension(nk) :: bot_connected_l, bot_connected_r top_connected_l(:) = .false. ; top_connected_r(:) = .false. bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. - ! Vectors with all the values of the discontinuous reconstruction. - ! Dimensions are [number of layers x number of interfaces]. Second dimension = 1 for top interface, = 2 for bottom -! real, dimension(nk,2) :: Sl, Sr, Tl, Tr, dRdT_l, dRdS_l, dRdT_r, dRdS_r - -! Check to make sure that polynomial reconstructions were passed if refine_pos defined) - refine_pos = .false. - if (present(refine_pos_in)) then - refine_pos = refine_pos_in - if (refine_pos .and. (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. & - present(ppoly_T_r) .and. present(ppoly_S_r) .and. & - present(tol_in) .and. present(max_iter) .and. present(ref_pres) ) )) & - call MOM_error(FATAL, "fine_neutral_surface_positions_discontinuous: refine_pos is requested, but polynomial"// & - "coefficients not available for T and S") + + ! Check to make sure that polynomial reconstructions were passed if refine_pos defined) + if(CS%refine_position) then + if (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. present(ppoly_T_r) .and. present(ppoly_S_r) )) & + call MOM_error(FATAL, "fine_neutral_surface_positions_discontinuous: refine_pos is requested, but " //& + "polynomial coefficients not available for T and S") endif - tolerance = 0. - if (present(tol_in)) tolerance = tol_in do k = 1,nk if (stable_l(k)) then kl_left = k @@ -1214,8 +1210,8 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, if (searching_left_column) then ! delta_rho is referenced to the right interface T, S, and P - if (present(ref_pres)) then - P_other = ref_pres + if (CS%ref_pres>=0.) then + P_other = CS%ref_pres else if (ki_right == 1) P_other = Pres_r(kl_right) if (ki_right == 2) P_other = Pres_r(kl_right+1) @@ -1226,9 +1222,9 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, dRdS_other = dRdS_r(kl_right, ki_right) ! Determine differences between right column interface and potentially three different parts of the left ! Potential density difference, rho(kl-1) - rho(kr) (should be negative) - if (refine_pos .and. (lastP_left > 0.) .and. (lastP_left < 1.)) then - call drho_at_pos(T_other, S_other, dRdT_other, dRdS_other, deg, Pres_l(kl_left), Pres_l(kl_left+1), & - ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), lastP_left, P_other, EOS, dRhoTop) + if (CS%refine_position .and. (lastP_left > 0.) .and. (lastP_left < 1.)) then + call drho_at_pos(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, Pres_l(kl_left), & + Pres_l(kl_left+1), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), lastP_left, dRhoTop) else dRhoTop = calc_drho(Tl(kl_left,1), Sl(kl_left,1), dRdT_l(kl_left,1), dRdS_l(kl_left,1), T_other, S_other, & dRdT_other, dRdS_other) @@ -1251,25 +1247,24 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, ! Set position within the searched column call search_other_column(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), lastP_left, lastK_left, kl_left, & - kl_left_0, ki_left, top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface), & - search_layer) + kl_left_0, ki_left, top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface), search_layer) - if ( refine_pos .and. search_layer ) then + if ( CS%refine_position .and. search_layer ) then min_bound = 0. if (k_surface > 1) then if ( KoL(k_surface) == KoL(k_surface-1) ) min_bound = PoL(k_surface-1) endif - PoL(k_surface) = refine_nondim_position(max_iter, tolerance, T_other, S_other, dRdT_other, dRdS_other, & - Pres_l(kl_left), Pres_l(kl_left+1), deg, ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), & - EOS, min_bound, dRhoTop, dRhoBot, min_bound, ref_pres) + PoL(k_surface) = refine_nondim_position( CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, & + Pres_l(kl_left), Pres_l(kl_left+1), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), & + dRhoTop, dRhoBot, min_bound ) endif if (PoL(k_surface) == 0.) top_connected_l(KoL(k_surface)) = .true. if (PoL(k_surface) == 1.) bot_connected_l(KoL(k_surface)) = .true. call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, searching_right_column, searching_left_column) elseif (searching_right_column) then - if (present(ref_pres)) then - P_other = ref_pres + if (CS%ref_pres>=0.) then + P_other = CS%ref_pres else if (ki_left == 1) P_other = Pres_l(kl_left) if (ki_left == 2) P_other = Pres_l(kl_left+1) @@ -1280,9 +1275,9 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, dRdS_other = dRdS_l(kl_left, ki_left) ! Interpolate for the neutral surface position within the right column, layer krm1 ! Potential density difference, rho(kr-1) - rho(kl) (should be negative) - if (refine_pos .and. (lastP_right > 0.) .and. (lastP_right<1.)) then - call drho_at_pos(T_other, S_other, dRdT_other, dRdS_other,deg, Pres_r(kl_right), Pres_l(kl_right+1), & - ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), lastP_right, P_other, EOS, dRhoTop) + if (CS%refine_position .and. (lastP_right > 0.) .and. (lastP_right<1.)) then + call drho_at_pos(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, Pres_r(kl_right), & + Pres_l(kl_right+1), ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), lastP_right, dRhoTop) else dRhoTop = calc_drho(Tr(kl_right,1), Sr(kl_right,1), dRdT_r(kl_right,1), dRdS_r(kl_right,1), & T_other, S_other, dRdT_other, dRdS_other) @@ -1305,14 +1300,14 @@ subroutine find_neutral_surface_positions_discontinuous(nk, ns, deg, call search_other_column(dRhoTop, dRhoBot, Pres_r(kl_right), Pres_r(kl_right+1), lastP_right, lastK_right, & kl_right, kl_right_0, ki_right, top_connected_r, bot_connected_r, PoR(k_surface), & KoR(k_surface), search_layer) - if ( refine_pos .and. search_layer) then + if ( CS%refine_position .and. search_layer) then min_bound = 0. if (k_surface > 1) then if ( KoR(k_surface) == KoR(k_surface-1) ) min_bound = PoR(k_surface-1) endif - PoR(k_surface) = refine_nondim_position(max_iter, tolerance, T_other, S_other, dRdT_other, dRdS_other, & - Pres_r(kl_right), Pres_r(kl_right+1), deg, ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), & - EOS, min_bound, dRhoTop, dRhoBot, min_bound, ref_pres) + PoR(k_surface) = refine_nondim_position(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, & + Pres_r(kl_right), Pres_r(kl_right+1), ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), & + dRhoTop, dRhoBot, min_bound ) endif if (PoR(k_surface) == 0.) top_connected_r(KoR(k_surface)) = .true. if (PoR(k_surface) == 1.) bot_connected_r(KoR(k_surface)) = .true. @@ -1783,6 +1778,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) integer, dimension(ns) :: KoL, KoR real, dimension(ns) :: PoL, PoR real, dimension(ns-1) :: hEff, Flx + type(neutral_diffusion_CS) :: CS type(EOS_type), pointer :: EOS ! Structure for linear equation of state type(remapping_CS), pointer :: remap_CS ! Remapping control structure (PLM) real, dimension(nk,2) :: poly_T_l, poly_T_r, poly_S, poly_slope ! Linear reconstruction for T @@ -1801,6 +1797,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Salinity is 0 for all these tests Sl(:) = 0. ; Sr(:) = 0. ; poly_S(:,:) = 0. ; SiL(:,:) = 0. ; SiR(:,:) = 0. dRdT(:,:) = -1. ; dRdS(:,:) = 0. + + ! Intialize any control structures needed for unit tests + CS%refine_position = .false. + CS%ref_pres = -1. allocate(remap_CS) call initialize_remapping( remap_CS, "PLM", boundary_extrapolation = .true. ) @@ -1812,7 +1812,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -1827,7 +1827,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoL @@ -1841,7 +1841,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoL @@ -1855,7 +1855,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,2,3,3,3,3,3,3,3/), & ! KoL @@ -1869,7 +1869,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,3,3,3,3,3,3,3,3/), & ! KoL @@ -1883,7 +1883,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoL @@ -1897,7 +1897,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/1,1,2,2,2,3,3,3,3,3,3,3/), & ! KoL @@ -1912,7 +1912,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 10, KoL, KoR, PoL, PoR, hEff, & (/1,1,1,1,2,2,2,3,3,3/), & ! KoL @@ -1927,7 +1927,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) Tir(:,1) = (/10.,14.,12./) ; TiR(:,2) = (/14.,12.,4./) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) call mark_unstable_cells( nk, dRdT, dRdS, Tir, Sir, stable_r, ns_r ) - call find_neutral_surface_positions_discontinuous(nk, ns_l+ns_r, 1, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & + call find_neutral_surface_positions_discontinuous(CS, nk, ns_l+ns_r, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & Pres_r, hR, TiR, SiR, dRdT, dRdS, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 8, KoL, KoR, PoL, PoR, hEff, & (/2,2,2,2,2,3,3,3/), & ! KoL @@ -1941,25 +1941,28 @@ logical function ndiff_unit_tests_discontinuous(verbose) allocate(EOS) call EOS_manual_init(EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 2.) ! Unit tests for refine_nondim_position + ALLOCATE(CS%ndiff_aux_CS) + call set_ndiff_aux_params(CS%ndiff_aux_CS, deg = 1, max_iter = 10, drho_tol = 0., xtol = 0., EOS = EOS) ! Tests using Newton's method ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & - 100, 0., 20., 35., -1., 2., 0., 1., 1, (/21., -2./), (/35., 0./), EOS, 0., -1., 1., 0., -1.), & + CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/35., 0./), -1., 1., 0.), & "Temperature stratified (Newton) ")) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & - 100, 0., 20., 35., -1., 2., 0., 1., 1, (/20., 0./), (/34., 2./), EOS, 0., -2., 2., 0., -1.), & + CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/20., 0./), (/34., 2./), -2., 2., 0.), & "Salinity stratified (Newton) ")) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & - 100, 0., 20., 35., -1., 2., 0., 1., 1, (/21., -2./), (/34., 2./), EOS, 0., -1., 1., 0., -1.), & + CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & "Temp/Salt stratified (Newton) ")) + call set_ndiff_aux_params(CS%ndiff_aux_CS, force_brent = .true.) ! Tests using Brent's method ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & - 100, 0., 20., 35., -1., 2., 0., 1., 1, (/21., -2./), (/35., 0./), EOS, 0., -1., 1., 0., -1., force_brent = .true.), & + CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/35., 0./), -1., 1., 0.), & "Temperature stratified (Brent) ")) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & - 100, 0., 20., 35., -1., 2., 0., 1., 1, (/20., 0./), (/34., 2./), EOS, 0., -2., 2., 0., -1., force_brent = .true.), & + CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/20., 0./), (/34., 2./), -2., 2., 0.), & "Salinity stratified (Brent) ")) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & - 100, 0., 20., 35., -1., 2., 0., 1., 1, (/21., -2./), (/34., 2./), EOS, 0., -1., 1., 0., -1., force_brent = .true.), & + CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & "Temp/Salt stratified (Brent) ")) deallocate(EOS) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 803e714ad7..a4a33a8445 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -9,6 +9,7 @@ module MOM_neutral_diffusion_aux ! This file is part of MOM6. See LICENSE.md for the license. implicit none ; private +public set_ndiff_aux_params public mark_unstable_cells public increment_interface public calc_drho @@ -16,11 +17,43 @@ module MOM_neutral_diffusion_aux public search_other_column public interpolate_for_nondim_position public refine_nondim_position -public check_neutral_positions public kahan_sum +type, public :: ndiff_aux_CS_type ; private + integer :: nterm !< Number of terms in polynomial (deg+1) + integer :: max_iter !< Maximum number of iterations + real :: drho_tol !< Tolerance criterion for difference in density (kg/m3) + real :: xtol !< Criterion for how much position changes (nondim) + real :: ref_pres !< Determines whether a constant reference pressure is used everywhere or locally referenced + !< density is done. ref_pres <-1 is the latter, ref_pres >= 0. otherwise + logical :: force_brent = .false. !< Use Brent's method instead of Newton even when second derivatives are available + type(EOS_type), pointer :: EOS !< Pointer to equation of state used in the model + +end type ndiff_aux_CS_type + contains +!> Initialize the parameters used to iteratively find the neutral direction +subroutine set_ndiff_aux_params( CS, deg, max_iter, drho_tol, xtol, ref_pres, force_brent, EOS) + type(ndiff_aux_CS_type), intent(inout) :: CS !< Control structure for refine_pos + integer, optional, intent(in ) :: deg !< Degree of polynommial used in reconstruction + integer, optional, intent(in ) :: max_iter !< Maximum number of iterations + real, optional, intent(in ) :: drho_tol !< Tolerance for function convergence + real, optional, intent(in ) :: xtol !< Tolerance for change in position + real, optional, intent(in ) :: ref_pres !< Reference pressure to use + logical, optional, intent(in ) :: force_brent !< Force Brent method for linear, TEOS-10, and WRIGHT + type(EOS_type), target, optional, intent(in ) :: EOS !< Equation of state + + if (present( deg )) CS%nterm = deg + 1 + if (present( max_iter )) CS%max_iter = max_iter + if (present( drho_tol )) CS%drho_tol = drho_tol + if (present( xtol )) CS%xtol = xtol + if (present( ref_pres )) CS%ref_pres = ref_pres + if (present( force_brent )) CS%force_brent = force_brent + if (present( EOS )) CS%EOS => EOS + +end subroutine set_ndiff_aux_params + !> Given the reconsturcitons of dRdT, dRdS, T, S mark the cells which are stably stratified parts of the water column !! For an layer to be unstable the top interface must be denser than the bottom or the bottom interface of the layer subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) @@ -123,21 +156,19 @@ real function calc_drho(T1, S1, dRdT1, dRdS1, T2, S2, dRdT2, dRdS2) end function calc_drho !> Calculate the difference in neutral density between a reference T, S, alpha, and beta -!! and a point on the polynomial reconstructions of T, S -subroutine drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, x0, ref_pres, EOS, & - delta_rho, P_out, T_out, S_out, alpha_avg_out, beta_avg_out, delta_T_out, delta_S_out) +!! and a poiet on the polynomial reconstructions of T, S +subroutine drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, x0, & + delta_rho, P_out, T_out, S_out, alpha_avg_out, beta_avg_out, delta_T_out, delta_S_out) + type(ndiff_aux_CS_type), intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: T_ref !< Temperature at reference surface real, intent(in) :: S_ref !< Salinity at reference surface real, intent(in) :: alpha_ref !< dRho/dT at reference surface real, intent(in) :: beta_ref !< dRho/dS at reference surface - integer, intent(in) :: deg !< Degree of polynomial reconstruction real, intent(in) :: P_top !< Pressure (Pa) at top interface of layer to be searched real, intent(in) :: P_bot !< Pressure (Pa) at bottom interface - real, dimension(deg+1), intent(in) :: ppoly_T !< Coefficients of T reconstruction - real, dimension(deg+1), intent(in) :: ppoly_S !< Coefficients of S reconstruciton + real, dimension(CS%nterm), intent(in) :: ppoly_T !< Coefficients of T reconstruction + real, dimension(CS%nterm), intent(in) :: ppoly_S !< Coefficients of S reconstruciton real, intent(in) :: x0 !< Nondimensional position to evaluate - real, intent(in) :: ref_pres !< Reference pressure - type(EOS_type), pointer :: EOS !< Equation of state structure real, intent(out) :: delta_rho real, optional, intent(out) :: P_out !< Pressure at point x0 real, optional, intent(out) :: T_out !< Temperature at point x0 @@ -150,14 +181,14 @@ subroutine drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppo real :: alpha, beta, alpha_avg, beta_avg, P_int, T, S, delta_T, delta_S P_int = (1. - x0)*P_top + x0*P_bot - T = evaluation_polynomial( ppoly_T, deg+1, x0 ) - S = evaluation_polynomial( ppoly_S, deg+1, x0 ) + T = evaluation_polynomial( ppoly_T, CS%nterm, x0 ) + S = evaluation_polynomial( ppoly_S, CS%nterm, x0 ) ! Interpolated pressure if using locally referenced neutral density - if (ref_pres<0.) then - call calculate_density_derivs( T, S, P_int, alpha, beta, EOS ) + if (CS%ref_pres<0.) then + call calculate_density_derivs( T, S, P_int, alpha, beta, CS%EOS ) else ! Constant reference pressure (isopycnal) - call calculate_density_derivs( T, S, ref_pres, alpha, beta, EOS ) + call calculate_density_derivs( T, S, CS%ref_pres, alpha, beta, CS%EOS ) endif ! Calculate the f(P) term for Newton's method @@ -292,7 +323,6 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) if ( interpolate_for_nondim_position > 1. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' end function interpolate_for_nondim_position - !> Use root-finding methods to find where dRho = 0, based on the equation of state and the polynomial !! reconstructions of temperature, salinity. Initial guess is based on the zero crossing of based on linear !! profiles of dRho, T, and S, between the top and bottom interface. If second derivatives of the EOS are available, @@ -300,29 +330,22 @@ end function interpolate_for_nondim_position !! to see if it it diverges outside the interval. In that case (or in the case that second derivatives are not !! available), Brent's method is used following the implementation found at !! https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.f90 -real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, deg, & - ppoly_T, ppoly_S, EOS, x0, drho_top, drho_bot, min_bound, ref_pres, force_brent) - integer, intent(in) :: max_iter !< Number of maximum iterations to use - real, intent(in) :: tolerance !< Convergence criterion for delta_rho - real, intent(in) :: T_ref !< Temperature of the neutral surface at the searched from interface - real, intent(in) :: S_ref !< Salinity of the neutral surface at the searched from interface - real, intent(in) :: alpha_ref !< dRho/dT of the neutral surface at the searched from interface - real, intent(in) :: beta_ref !< dRho/dS of the neutral surface at the searched from interface - real, intent(in) :: P_top !< Pressure at the top interface in the layer to be searched - real, intent(in) :: P_bot !< Pressure at the bottom interface in the layer to be searched - integer, intent(in) :: deg !< Order of the polynomimal used for reconstructions - real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the order N polynomial reconstruction of T within - !! the layer to be searched. - real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the order N polynomial reconstruction of T within - !! the layer to be searched. - real, intent(in) :: x0 !< Nondimensional position within the layer where the neutral - !! surface connects. If interpolate_for_nondim_position was - !! previously called, this would be based on linear profile of dRho - real, intent(in) :: drho_top, drho_bot, min_bound - real, intent(in) :: ref_pres !< Optionally use a different reference pressure other than local - type(EOS_type), pointer :: EOS !< Equation of state structure - logical, optional, intent(in) :: force_brent !< Forces the use of Brent's method instead of Newton's method to find - !! position of neutral surface +real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, drho_top, & + drho_bot, min_bound) + type(ndiff_aux_CS_type), intent(in) :: CS !< Control structure with parameters for this module + real, intent(in) :: T_ref !< Temperature of the neutral surface at the searched from interface + real, intent(in) :: S_ref !< Salinity of the neutral surface at the searched from interface + real, intent(in) :: alpha_ref !< dRho/dT of the neutral surface at the searched from interface + real, intent(in) :: beta_ref !< dRho/dS of the neutral surface at the searched from interface + real, intent(in) :: P_top !< Pressure at the top interface in the layer to be searched + real, intent(in) :: P_bot !< Pressure at the bottom interface in the layer to be searched + real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the order N polynomial reconstruction of T within + !! the layer to be searched. + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the order N polynomial reconstruction of T within + !! the layer to be searched. + real, intent(in) :: drho_top !< Delta rho at top interface (or previous position in cell + real, intent(in) :: drho_bot !< Delta rho at bottom interface + real, intent(in) :: min_bound !< Lower bound of position, also serves as the initial guess ! Local variables integer :: form_of_EOS @@ -341,33 +364,33 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re real :: d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep real :: P_last - logical :: debug = .true. - if (ref_pres>=0.) P_ref = ref_pres + logical :: debug = .false. + if (CS%ref_pres>=0.) P_ref = CS%ref_pres delta_P = P_bot-P_top refine_nondim_position = min_bound - call extract_member_EOS(EOS, form_of_EOS = form_of_EOS) + call extract_member_EOS(CS%EOS, form_of_EOS = form_of_EOS) do_newton = (form_of_EOS == EOS_LINEAR) .or. (form_of_EOS == EOS_TEOS10) .or. (form_of_EOS == EOS_WRIGHT) do_brent = .not. do_newton - if (present(force_brent)) then - do_newton = .not. force_brent - do_brent = force_brent + if (CS%force_brent) then + do_newton = .not. CS%force_brent + do_brent = CS%force_brent endif ! Calculate the initial values - call drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, min_bound, & - ref_pres, EOS, delta_rho, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) + call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, min_bound, & + delta_rho, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) delta_rho_init = delta_rho - if ( ABS(delta_rho_init) < tolerance ) then + if ( ABS(delta_rho_init) <= CS%drho_tol ) then refine_nondim_position = min_bound return endif - - if ( delta_rho_init > 0.) then + if (ABS(drho_bot) <= CS%drho_tol) then refine_nondim_position = 1. return endif + if (debug) then write (*,*) "------" write (*,*) "Starting x0, delta_rho: ", min_bound, delta_rho @@ -383,19 +406,19 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re fb = delta_rho_init ; b = min_bound fc = drho_bot ; c = 1. ! Iterate over Newton's method for the function: x0 = x0 - delta_rho/d_delta_rho_dP - do iter = 1, max_iter + do iter = 1, CS%max_iter P_int = P_top*(1. - b) + P_bot*b ! Evaluate total derivative of delta_rho - if (ref_pres<0.) P_ref = P_int - call calculate_density_second_derivs( T, S, P_ref, dbeta_dS, dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, EOS ) + if (CS%ref_pres<0.) P_ref = P_int + call calculate_density_second_derivs( T, S, P_ref, dbeta_dS, dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, CS%EOS ) ! In the case of a constant reference pressure, no dependence on neutral direction with pressure - if (ref_pres>=0.) then + if (CS%ref_pres>=0.) then dalpha_dP = 0. ; dbeta_dP = 0. endif dalpha_dS = dbeta_dT ! Cross derivatives are identicial ! By chain rule dT_dP= (dT_dz)*(dz/dP) = dT_dz / (Pbot-Ptop) - dT_dP = first_derivative_polynomial( ppoly_T, deg+1, refine_nondim_position ) / delta_P - dS_dP = first_derivative_polynomial( ppoly_S, deg+1, refine_nondim_position ) / delta_P + dT_dP = first_derivative_polynomial( ppoly_T, CS%nterm, refine_nondim_position ) / delta_P + dS_dP = first_derivative_polynomial( ppoly_S, CS%nterm, refine_nondim_position ) / delta_P ! Total derivative of d_delta_rho wrt P d_delta_rho_dP = 0.5*( delta_S*(dS_dP*dbeta_dS + dT_dP*dbeta_dT + dbeta_dP) + & ( delta_T*(dS_dP*dalpha_dS + dT_dP*dalpha_dT + dalpha_dP))) + & @@ -415,12 +438,18 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re b = 0.5*(a + c) endif endif - call drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, & - b, ref_pres, EOS, fb, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) + call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & + b, fb, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) if (debug) print *, "Iteration, b, fb: ", iter, b, fb -! if (ABS(fb) <= tolerance .or. ABS(b-b_last) <= tolerance ) then - if( (fb <= 0.) .and. (fb >= -tolerance) ) then - refine_nondim_position = P_int/delta_P + ! For the logic to find neutral surfaces to work properly, the function needs to converge to zero + ! or a small negative value + if( (fb <= 0.) .and. (fb >= -CS%drho_tol) ) then + refine_nondim_position = b + exit + endif + ! Exit if method has stalled out + if ( ABS(b-b_last)<=CS%xtol ) then + refine_nondim_position = b exit endif @@ -445,7 +474,7 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re ! This is from https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.f90 - do iter = 1,max_iter + do iter = 1,CS%max_iter if ( abs ( fc ) < abs ( fb ) ) then sa = sb sb = c @@ -454,7 +483,7 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re fb = fc fc = fa end if - tol = 2. * machep * abs ( sb ) + tolerance + tol = 2. * machep * abs ( sb ) + CS%xtol m = 0.5 * ( c - sb ) if ( abs ( m ) <= tol .or. fb == 0. ) then exit @@ -497,8 +526,8 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re else sb = sb - tol end if - call drho_at_pos(T_ref, S_ref, alpha_ref, beta_ref, deg, P_top, P_bot, ppoly_T, ppoly_S, & - sb, ref_pres, EOS, fb) + call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & + sb, fb) if ( ( 0. < fb .and. 0. < fc ) .or. & ( fb <= 0. .and. fc <= 0. ) ) then c = sa @@ -528,11 +557,11 @@ real function refine_nondim_position(max_iter, tolerance, T_ref, S_ref, alpha_re write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref write (*,*) "P, dT_dP, dS_dP:", P_int, dT_dP, dS_dP - write (*,*) "x0: ", x0 + write (*,*) "x0: ", min_bound write (*,*) "refine_nondim_position: ", refine_nondim_position endif call MOM_error(WARNING, "refine_nondim_position>1.") - refine_nondim_position = MAX(x0,min_bound) + refine_nondim_position = 1. endif if (refine_nondim_position Returns .true. if the endpoints of neutral surface do not have the same density (within a specified tolerance) -logical function check_neutral_positions(deg, EOS, x_l, T_poly_l, S_poly_l, P_l, x_r, T_poly_r, S_poly_r, P_r, tolerance, ref_pres) - integer :: deg !< Degree of polynomial - type(EOS_type), pointer :: EOS - real :: x_l !< Nondim position within layer (left) - real, dimension(deg+1) :: T_poly_l !< Coefficients of polynomial reconstructions of T (left) - real, dimension(deg+1) :: S_poly_l !< Coefficients of polynomial reconstructions of S (left) - real, dimension(2) :: P_l !< Pressure at top and bottom of layer (left) - real :: x_r !< Nondim position within layer (left) - real, dimension(deg+1) :: T_poly_r !< Coefficients of polynomial reconstructions of T (right) - real, dimension(deg+1) :: S_poly_r !< Coefficients of polynomial reconstructions of S (right) - real, dimension(2) :: P_r !< Pressure at top and bottom of layer (right) - real :: tolerance !< How close to the difference in density should be - real, optional :: ref_pres !< reference pressure if not usign local pressure - - real :: delta_rho - real :: Pl, Tl, Sl, alpha_l, beta_l - real :: Pr, Tr, Sr, alpha_r, beta_r - - Tl = evaluation_polynomial( T_poly_l, deg+1, x_l ) - Tr = evaluation_polynomial( T_poly_r, deg+1, x_r ) - Sl = evaluation_polynomial( S_poly_l, deg+1, x_l ) - Sr = evaluation_polynomial( S_poly_r, deg+1, x_r ) - - if (ref_pres>0.) then - call calculate_density_derivs( Tl, Sl, ref_pres, alpha_l, beta_l, EOS ) - call calculate_density_derivs( Tr, Sr, ref_pres, alpha_r, beta_r, EOS ) - else - Pl = (1. - x_l)*P_l(1) + x_l*P_l(2) - Pr = (1. - x_r)*P_r(1) + x_l*P_r(2) - call calculate_density_derivs( Tl, Sl, Pl, alpha_l, beta_l, EOS ) - call calculate_density_derivs( Tr, Sr, Pr, alpha_r, beta_r, EOS ) - endif - - delta_rho = 0.5*( (alpha_l+alpha_r)*(Tl-Tr) + (beta_l+beta_r)*(Sl-Sr) ) - check_neutral_positions = ABS(delta_rho)>tolerance - - if (check_neutral_positions) then - write (*,*) "Density difference of", delta_rho - endif - -end function check_neutral_positions !> Do a compensated sum to account for roundoff level subroutine kahan_sum(sum, summand, c) real, intent(inout) :: sum !< Running sum diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 6477fd4aab..d02731cb8b 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -11,7 +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_EOS, only : calculate_density +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 use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -333,8 +333,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla ! 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, tv%eqn_of_state, & - CS%neutral_diffusion_CSp) + call neutral_diffusion_calc_coeffs(G, GV, 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 @@ -1326,10 +1325,11 @@ end subroutine tracer_epipycnal_ML_diff !> Initialize lateral tracer diffusion module -subroutine tracer_hor_diff_init(Time, G, param_file, diag, CS, CSnd) +subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS, CSnd) 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(param_file_type), intent(in) :: param_file !< parameter file type(tracer_hor_diff_CS), pointer :: CS !< horz diffusion control structure type(neutral_diffusion_CS), pointer :: CSnd !< pointer to neutral diffusion CS @@ -1392,7 +1392,7 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, CS, CSnd) units="nondim", default=1.0) endif - CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, CS%neutral_diffusion_CSp) + CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, EOS, CS%neutral_diffusion_CSp) CSnd => 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!") From 89c1dac869f3252419b2bda7fd262ec9b18311c4 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 12 Dec 2017 14:11:40 -0500 Subject: [PATCH 048/170] Remove module level variable debug_this_module was removed as module-level variable and is now encased in the CS for neutral diffusion --- src/tracer/MOM_neutral_diffusion.F90 | 15 +++++----- src/tracer/MOM_neutral_diffusion_aux.F90 | 35 ++++++++++++++++++------ 2 files changed, 34 insertions(+), 16 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 9f5e086bb5..234c11b95e 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 :: refine_position = .false. + logical :: debug integer :: max_iter ! Maximum number of iterations if refine_position is defined real :: tolerance ! Convergence criterion representing difference from true neutrality real :: ref_pres ! Reference pressure, negative if using locally referenced neutral density @@ -94,8 +95,6 @@ module MOM_neutral_diffusion #include "version_variable.h" character(len=40) :: mdl = "MOM_neutral_diffusion" ! module name -logical :: debug_this_module = .false. ! If true, verbose output of find neutral position - contains !> Read parameters and allocate control structure for neutral_diffusion module. @@ -185,11 +184,11 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) default=10) call set_ndiff_aux_params(CS%ndiff_aux_CS, max_iter = max_iter, drho_tol = drho_tol, xtol = xtol) endif - call set_ndiff_aux_params(CS%ndiff_aux_CS, deg=CS%deg, ref_pres = CS%ref_pres, EOS = EOS) - call get_param(param_file, mdl, "NDIFF_DEBUG", debug_this_module, & + call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & "Turns on verbose output for discontinuous neutral \n"// & "diffusion routines.", & default = .false.) + call set_ndiff_aux_params(CS%ndiff_aux_CS, deg=CS%deg, ref_pres = CS%ref_pres, EOS = EOS, debug = CS%debug) endif ! call get_param(param_file, mdl, "KHTR", CS%KhTr, & @@ -1187,7 +1186,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, dRho = 0.5 * & ( ( dRdT_r(kl_right,ki_right) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,ki_right) - Tl(kl_left,ki_left) ) & + ( dRdS_r(kl_right,ki_right) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,ki_right) - Sl(kl_left,ki_left) ) ) - if (debug_this_module) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho," & + if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho," & kl_left=",kl_left, " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right ! Which column has the lighter surface for the current indexes, kr and kl if (.not. reached_bottom) then @@ -1232,7 +1231,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, ! Potential density difference, rho(kl) - rho(kl_right,ki_right) (will be positive) dRhoBot = calc_drho(Tl(kl_left,2), Sl(kl_left,2), dRdT_l(kl_left,2), dRdS_l(kl_left,2), & T_other, S_other, dRdT_other, dRdS_other) - if (debug_this_module) then + if (CS%debug) then write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching left layer ", kl_left, & " dRhoTop=", dRhoTop, " dRhoBot=", dRhoBot write(*,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right @@ -1284,7 +1283,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, endif dRhoBot = calc_drho(Tr(kl_right,2), Sr(kl_right,2), dRdT_r(kl_right,2), dRdS_r(kl_right,2), & T_other, S_other, dRdT_other, dRdS_other) - if (debug_this_module) then + if (CS%debug) then write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching right layer ", kl_right, & " dRhoTop=", dRhoTop, " dRhoBot=", dRhoBot write(*,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left @@ -1319,7 +1318,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) - if (debug_this_module) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & + if (CS%debug) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & KoR(k_surface), " PoR:", PoR(k_surface) ! Effective thickness if (k_surface>1) then diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index a4a33a8445..43748f2890 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -27,6 +27,7 @@ module MOM_neutral_diffusion_aux real :: ref_pres !< Determines whether a constant reference pressure is used everywhere or locally referenced !< density is done. ref_pres <-1 is the latter, ref_pres >= 0. otherwise logical :: force_brent = .false. !< Use Brent's method instead of Newton even when second derivatives are available + logical :: debug type(EOS_type), pointer :: EOS !< Pointer to equation of state used in the model end type ndiff_aux_CS_type @@ -34,7 +35,7 @@ module MOM_neutral_diffusion_aux contains !> Initialize the parameters used to iteratively find the neutral direction -subroutine set_ndiff_aux_params( CS, deg, max_iter, drho_tol, xtol, ref_pres, force_brent, EOS) +subroutine set_ndiff_aux_params( CS, deg, max_iter, drho_tol, xtol, ref_pres, force_brent, EOS, debug) type(ndiff_aux_CS_type), intent(inout) :: CS !< Control structure for refine_pos integer, optional, intent(in ) :: deg !< Degree of polynommial used in reconstruction integer, optional, intent(in ) :: max_iter !< Maximum number of iterations @@ -42,6 +43,7 @@ subroutine set_ndiff_aux_params( CS, deg, max_iter, drho_tol, xtol, ref_pres, fo real, optional, intent(in ) :: xtol !< Tolerance for change in position real, optional, intent(in ) :: ref_pres !< Reference pressure to use logical, optional, intent(in ) :: force_brent !< Force Brent method for linear, TEOS-10, and WRIGHT + logical, optional, intent(in ) :: debug !< If true, print output use to help debug neutral diffusion type(EOS_type), target, optional, intent(in ) :: EOS !< Equation of state if (present( deg )) CS%nterm = deg + 1 @@ -51,6 +53,7 @@ subroutine set_ndiff_aux_params( CS, deg, max_iter, drho_tol, xtol, ref_pres, fo if (present( ref_pres )) CS%ref_pres = ref_pres if (present( force_brent )) CS%force_brent = force_brent if (present( EOS )) CS%EOS => EOS + if (present( debug )) CS%debug = debug end subroutine set_ndiff_aux_params @@ -246,6 +249,8 @@ subroutine search_other_column(dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, k endif elseif (dRhoTop >= dRhoBot) then out_P = 1. ; out_K = kl + elseif (dRhoTop < 0. .and. dRhoBot < 0.)then + out_P = 1. ; out_K = kl else out_K = kl out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) @@ -279,6 +284,8 @@ subroutine search_other_column(dRhoTop, dRhoBot, Ptop, Pbot, lastP, lastK, kl, k endif elseif (dRhoTop >= dRhoBot) then out_P = 1. ; out_K = kl + elseif (dRhoTop < 0. .and. dRhoBot < 0.)then + out_P = 1. ; out_K = kl else out_K = kl out_P = max(interpolate_for_nondim_position( dRhoTop, Ptop, dRhoBot, Pbot ),lastP) @@ -355,6 +362,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to real :: delta_rho, d_delta_rho_dP ! Terms for the Newton iteration real :: P_int, P_min, P_ref ! Interpolated pressure real :: delta_rho_init, delta_rho_final + real :: neg_x, neg_fun real :: T, S, alpha, beta, alpha_avg, beta_avg ! Newton's Method with variables real :: dT_dP, dS_dP, delta_T, delta_S, delta_P @@ -364,7 +372,6 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to real :: d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep real :: P_last - logical :: debug = .false. if (CS%ref_pres>=0.) P_ref = CS%ref_pres delta_P = P_bot-P_top refine_nondim_position = min_bound @@ -390,8 +397,11 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to return endif + ! Set the initial values to ensure that the algorithm returns a 'negative' value + neg_fun = delta_rho + neg_x = min_bound - if (debug) then + if (CS%debug) then write (*,*) "------" write (*,*) "Starting x0, delta_rho: ", min_bound, delta_rho endif @@ -440,7 +450,13 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to endif call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & b, fb, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) - if (debug) print *, "Iteration, b, fb: ", iter, b, fb + if (CS%debug) print *, "Iteration, b, fb: ", iter, b, fb + + if (fb < 0. .and. fb > neg_fun) then + neg_fun = fb + neg_x = b + endif + ! For the logic to find neutral surfaces to work properly, the function needs to converge to zero ! or a small negative value if( (fb <= 0.) .and. (fb >= -CS%drho_tol) ) then @@ -465,7 +481,10 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to refine_nondim_position = b delta_rho = fb endif - + if (delta_rho > 0.) then + refine_nondim_position = neg_x + delta_rho = neg_fun + endif ! Do Brent if analytic second derivatives don't exist if (do_brent) then sa = max(refine_nondim_position,min_bound) ; fa = delta_rho @@ -551,7 +570,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! Make sure that the result is bounded between 0 and 1 if (refine_nondim_position>1.) then - if (debug) then + if (CS%debug) then write (*,*) "T, T Poly Coeffs: ", T, ppoly_T write (*,*) "S, S Poly Coeffs: ", S, ppoly_S write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref @@ -565,7 +584,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to endif if (refine_nondim_position Date: Tue, 12 Dec 2017 11:36:46 -0900 Subject: [PATCH 049/170] Added option for mean + oscillating flow to dyed channel. --- src/user/dyed_channel_initialization.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index 0974d15671..f6b3e0f9a8 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -25,8 +25,9 @@ module dyed_channel_initialization !> Control structure for tidal bay open boundaries. type, public :: dyed_channel_OBC_CS ; private - real :: zonal_flow = 8.57 !< Maximum inflow - real :: frequency = 0.0 !< Inflow frequency + real :: zonal_flow = 8.57 !< Mean inflow + real :: tidal_amp = 0.0 !< Sloshing amplitude + real :: frequency = 0.0 !< Sloshing frequency end type dyed_channel_OBC_CS integer :: ntr = 0 @@ -49,9 +50,12 @@ function register_dyed_channel_OBC(param_file, CS, OBC_Reg) endif allocate(CS) - call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", CS%zonal_flow, & - "Constant zonal flow imposed at upstream open boundary.", & + call get_param(param_file, mdl, "CHANNEL_MEAN_FLOW", CS%zonal_flow, & + "Mean zonal flow imposed at upstream open boundary.", & units="m/s", default=8.57) + call get_param(param_file, mdl, "CHANNEL_TIDAL_AMP", CS%tidal_amp, & + "Sloshing amplitude imposed at upstream open boundary.", & + units="m/s", default=0.0) call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & "Frequency of oscillating zonal flow.", & units="s-1", default=0.0) @@ -161,7 +165,7 @@ subroutine dyed_channel_update_flow(OBC, CS, G, Time) if (CS%frequency == 0.0) then flow = CS%zonal_flow else - flow = CS%zonal_flow * cos(2 * PI * CS%frequency * time_sec) + flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) endif do k=1,G%ke do j=jsd,jed ; do I=IsdB,IedB From 56b87cbde502c729a73783a001bebf75cbf51672 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 13 Dec 2017 16:19:44 -0500 Subject: [PATCH 050/170] Some useful routines and diagnostics for debugging neutral diffusion --- src/tracer/MOM_neutral_diffusion.F90 | 71 +++++++++++++++++++++--- src/tracer/MOM_neutral_diffusion_aux.F90 | 53 ++++++++++++++++++ 2 files changed, 116 insertions(+), 8 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 234c11b95e..645c432f87 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -17,6 +17,7 @@ module MOM_neutral_diffusion use MOM_neutral_diffusion_aux, only : ndiff_aux_CS_type, set_ndiff_aux_params use MOM_neutral_diffusion_aux, only : mark_unstable_cells, increment_interface, calc_drho, drho_at_pos use MOM_neutral_diffusion_aux, only : search_other_column, interpolate_for_nondim_position, refine_nondim_position +use MOM_neutral_diffusion_aux, only : check_neutral_positions 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 @@ -84,6 +85,10 @@ module MOM_neutral_diffusion integer, allocatable, dimension(:) :: id_neutral_diff_tracer_cont_tend_2d ! k-summed tracer content tendency integer, allocatable, dimension(:) :: id_neutral_diff_tracer_trans_x_2d ! k-summed ndiff zonal tracer transport integer, allocatable, dimension(:) :: id_neutral_diff_tracer_trans_y_2d ! k-summed ndiff merid tracer transport + integer :: id_stable_cell = -1 + integer :: id_uhEff_2d = -1 + integer :: id_vhEff_2d = -1 + real :: C_p ! heat capacity of seawater (J kg-1 K-1) type(EOS_type), pointer :: EOS !< Equation of state parameters @@ -364,6 +369,13 @@ subroutine neutral_diffusion_diag_init(Time, G, diag, C_p, Reg, CS) enddo + CS%id_stable_cell = register_diag_field('ocean_model', 'ndiff_stable_cell', diag%axesTl, Time, & + '1 if the cell is stably stratified wrt to the one below and above', 'none') + CS%id_uheff_2d = register_diag_field('ocean_model', 'uhEff_2d', diag%axesCu1, Time, & + 'Total thickness of diffusive sublayers at u-points', 'm') + CS%id_vheff_2d = register_diag_field('ocean_model', 'vhEff_2d', diag%axesCv1, Time, & + 'Total thickness of diffusive sublayers at v-points', 'm') + end subroutine neutral_diffusion_diag_init @@ -381,6 +393,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) integer :: i, j, k ! Variables used for reconstructions real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes + real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: stable_cell_real + real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta real :: dRho, P_lay @@ -457,6 +471,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 call mark_unstable_cells( G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) enddo ; enddo + do k = 1,G%ke ; do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 + if (CS%stable_cell(i,j,k)) then + stable_cell_real(i,j,k) = 1. + else + stable_cell_real(i,j,k) = 0. + endif + enddo ; enddo ; enddo + if (CS%id_stable_cell>0) call post_data(CS%id_stable_cell, stable_cell_real, CS%diag) endif CS%uhEff(:,:,:) = 0. @@ -518,6 +540,21 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) CS%vhEff(:,:,:) = CS%vhEff(:,:,:) / GV%H_to_pa endif + if (CS%id_uhEff_2d>0) then + hEff_sum(:,:) = 0. + do k = 1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc-1,G%iec + hEff_sum(i,j) = hEff_sum(i,j) + CS%uhEff(i,j,k) + enddo ; enddo; enddo + call post_data(CS%id_uhEff_2d, hEff_sum, CS%diag) + endif + if (CS%id_vhEff_2d>0) then + hEff_sum(:,:) = 0. + do k = 1,G%ke ; do j=G%jsc-1,G%jec ; do i=G%isc,G%iec + hEff_sum(i,j) = hEff_sum(i,j) + CS%vhEff(i,j,k) + enddo ; enddo; enddo + call post_data(CS%id_vhEff_2d, hEff_sum, CS%diag) + endif + end subroutine neutral_diffusion_calc_coeffs !> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. @@ -1219,9 +1256,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, S_other = Sr(kl_right, ki_right) dRdT_other = dRdT_r(kl_right, ki_right) dRdS_other = dRdS_r(kl_right, ki_right) - ! Determine differences between right column interface and potentially three different parts of the left - ! Potential density difference, rho(kl-1) - rho(kr) (should be negative) - if (CS%refine_position .and. (lastP_left > 0.) .and. (lastP_left < 1.)) then + if (CS%refine_position .and. (lastK_left == kl_left)) then call drho_at_pos(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, Pres_l(kl_left), & Pres_l(kl_left+1), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), lastP_left, dRhoTop) else @@ -1274,7 +1309,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, dRdS_other = dRdS_l(kl_left, ki_left) ! Interpolate for the neutral surface position within the right column, layer krm1 ! Potential density difference, rho(kr-1) - rho(kl) (should be negative) - if (CS%refine_position .and. (lastP_right > 0.) .and. (lastP_right<1.)) then + if (CS%refine_position .and. (lastK_right == kl_right)) then call drho_at_pos(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, Pres_r(kl_right), & Pres_l(kl_right+1), ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), lastP_right, dRhoTop) else @@ -1339,6 +1374,24 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, endif endif enddo neutral_surfaces + if (CS%debug) then + print *, "==========Start Neutral Surfaces==========" + do k = 1,ns-1 + if (hEff(k)>0.) then + kl_left = KoL(k) + kl_right = KoR(k) + call check_neutral_positions(CS%ndiff_aux_CS, Pres_l(kl_left), Pres_l(kl_left+1), Pres_r(kl_right), & + Pres_r(kl_right+1), PoL(k), PoR(k), ppoly_T_l(kl_left,:), ppoly_T_r(kl_right,:), & + ppoly_S_l(kl_left,:), ppoly_S_r(kl_right,:)) + kl_left = KoL(k+1) + kl_right = KoR(k+1) + call check_neutral_positions(CS%ndiff_aux_CS, Pres_l(kl_left), Pres_l(kl_left+1), Pres_r(kl_right), & + Pres_r(kl_right+1), PoL(k), PoR(k), ppoly_T_l(kl_left,:), ppoly_T_r(kl_right,:), & + ppoly_S_l(kl_left,:), ppoly_S_r(kl_right,:)) + endif + enddo + print *, "==========End Neutral Surfaces==========" + endif end subroutine find_neutral_surface_positions_discontinuous @@ -1485,16 +1538,18 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K PiR(k_sublayer), PiR(k_sublayer+1)) dT_top = T_right_top - T_left_top dT_bottom = T_right_bottom - T_left_bottom - dT_layer = T_right_layer - T_left_layer + dT_ave = T_right_layer - T_left_layer + dT_layer = Tr(klt) - Tl(krt) dT_ave = dT_layer endif - if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then + if (signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then dT_ave = 0. else - dT_ave = dT_layer + dT_ave = dT_ave endif - Flx(k_sublayer) = dT_ave * hEff(k_sublayer) + dT_ave = dT_ave endif + Flx(k_sublayer) = dT_ave * hEff(k_sublayer) enddo end subroutine neutral_surface_flux diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 43748f2890..bceca444d5 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -17,6 +17,7 @@ module MOM_neutral_diffusion_aux public search_other_column public interpolate_for_nondim_position public refine_nondim_position +public check_neutral_positions public kahan_sum type, public :: ndiff_aux_CS_type ; private @@ -79,6 +80,11 @@ subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) stable_cell(k) = delta_rho >= 0. enddo + if (ANY(.not. stable_cell)) then + print *, "Unstable cell 1" + endif + + first_stable = 1 ! Check to see that bottom interface of upper cell is lighter than the upper interface of the lower cell do k=1,nk if (stable_cell(k)) then @@ -100,6 +106,9 @@ subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) ! If the lower cell is marked as stable, then it should be the next reference cell if (stable_cell(k)) prev_stable = k enddo + if (ANY(.not. stable_cell)) then + print *, "Unstable cell 2" + endif ! Number of interfaces is the 2 times number of stable cells in the water column ns = 0 @@ -446,6 +455,9 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! Test to see if it fell out of the bracketing interval. If so, take a bisection step if (b < a .or. b > c) then b = 0.5*(a + c) + if (CS%debug) print *, "Bisection step size: ", b-b_last + else + if (CS%debug) print *, "Newton step size, f'(b): ", (fb/d_delta_rho_dP)/delta_P, d_delta_rho_dP endif endif call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & @@ -604,11 +616,52 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to write (*,*) "x0, delta_x: ", min_bound, refine_nondim_position-min_bound write (*,*) "refine_nondim_position: ", refine_nondim_position write (*,*) "Iterations: ", iter + write (*,*) "T_poly_coeffs: ", ppoly_T + write (*,*) "S_poly_coeffs: ", ppoly_S write (*,*) "******" endif end function refine_nondim_position +subroutine check_neutral_positions(CS, Ptop_l, Pbot_l, Ptop_r, Pbot_r, PoL, PoR, Tl_coeffs, Tr_coeffs, & + Sl_coeffs, Sr_coeffs) + type(ndiff_aux_CS_type), intent(in) :: CS !< Control structure with parameters for this module + real, intent(in) :: Ptop_l !< Pressure at top interface of left cell + real, intent(in) :: Pbot_l !< Pressure at bottom interface of left cell + real, intent(in) :: Ptop_r !< Pressure at top interface of right cell + real, intent(in) :: Pbot_r !< Pressure at bottom interface of right cell + real, intent(in) :: PoL !< Nondim position in left cell + real, intent(in) :: PoR !< Nondim position in right cell + real, dimension(CS%nterm), intent(in) :: Tl_coeffs !< T polynomial coefficients of left cell + real, dimension(CS%nterm), intent(in) :: Tr_coeffs !< T polynomial coefficients of right cell + real, dimension(CS%nterm), intent(in) :: Sl_coeffs !< S polynomial coefficients of left cell + real, dimension(CS%nterm), intent(in) :: Sr_coeffs !< S polynomial coefficients of right cell + ! Local variables + real :: Pl, Pr, Tl, Tr, Sl, Sr + real :: alpha_l, alpha_r, beta_l, beta_r + real :: delta_rho + + Pl = (1. - PoL)*Ptop_l + PoL*Pbot_l + Pr = (1. - PoR)*Ptop_r + PoR*Pbot_r + Tl = evaluation_polynomial( Tl_coeffs, CS%nterm, PoL ) + Sl = evaluation_polynomial( Sl_coeffs, CS%nterm, PoL ) + Tr = evaluation_polynomial( Tr_coeffs, CS%nterm, PoR ) + Sr = evaluation_polynomial( Sr_coeffs, CS%nterm, PoR ) + + if (CS%ref_pres<0.) then + call calculate_density_derivs( Tl, Sl, Pl, alpha_l, beta_l, CS%EOS ) + call calculate_density_derivs( Tr, Sr, Pr, alpha_r, beta_r, CS%EOS ) + else + call calculate_density_derivs( Tl, Sl, CS%ref_pres, alpha_l, beta_l, CS%EOS ) + call calculate_density_derivs( Tr, Sr, CS%ref_pres, alpha_r, beta_r, CS%EOS ) + endif + + delta_rho = 0.5*( (alpha_l + alpha_r)*(Tl - Tr) + (beta_l + beta_r)*(Sl - Sr) ) + print *, "Delta-rho: ", delta_rho + + +end subroutine check_neutral_positions + !> Do a compensated sum to account for roundoff level subroutine kahan_sum(sum, summand, c) real, intent(inout) :: sum !< Running sum From 928ca57c24e2c0cefb18d942a7a1ecf53280a71c Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 14 Dec 2017 13:59:46 -0500 Subject: [PATCH 051/170] Cleanup the last of the changes to the neutral diffusion code --- src/tracer/MOM_neutral_diffusion.F90 | 57 +++++++----------------- src/tracer/MOM_neutral_diffusion_aux.F90 | 25 +++-------- 2 files changed, 23 insertions(+), 59 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 645c432f87..0383c34741 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -75,8 +75,6 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: dRdT_i ! dRho/dT (kg/m3/degC) at top edge real, allocatable, dimension(:,:,:,:) :: dRdS_i ! dRho/dS (kg/m3/ppt) at top edge integer, allocatable, dimension(:,:) :: ns ! Number of interfacs in a column - real, allocatable, dimension(:,:,:) :: dRdT_l ! dRho/dT (kg/m3/degC) cell average - real, allocatable, dimension(:,:,:) :: dRdS_l ! dRho/dS (kg/m3/ppt) cell average logical, allocatable, dimension(:,:,:) :: stable_cell ! True if the cell is stably stratified wrt to the next cell type(diag_ctrl), pointer :: diag ! structure to regulate output @@ -85,11 +83,9 @@ module MOM_neutral_diffusion integer, allocatable, dimension(:) :: id_neutral_diff_tracer_cont_tend_2d ! k-summed tracer content tendency integer, allocatable, dimension(:) :: id_neutral_diff_tracer_trans_x_2d ! k-summed ndiff zonal tracer transport integer, allocatable, dimension(:) :: id_neutral_diff_tracer_trans_y_2d ! k-summed ndiff merid tracer transport - integer :: id_stable_cell = -1 integer :: id_uhEff_2d = -1 integer :: id_vhEff_2d = -1 - 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 @@ -219,8 +215,6 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) allocate(CS%Sint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Sint(:,:,:) = 0. allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(G)+1)) ; CS%Pint(:,:,:) = 0. allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(G))) ; CS%stable_cell(:,:,:) = .true. - allocate(CS%dRdT_l(SZI_(G),SZJ_(G),SZK_(G))) ; CS%dRdT_l(:,:,:) = 0. - allocate(CS%dRdS_l(SZI_(G),SZJ_(G),SZK_(G))) ; CS%dRdS_l(:,:,:) = 0. ! U-points allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. @@ -369,8 +363,6 @@ subroutine neutral_diffusion_diag_init(Time, G, diag, C_p, Reg, CS) enddo - CS%id_stable_cell = register_diag_field('ocean_model', 'ndiff_stable_cell', diag%axesTl, Time, & - '1 if the cell is stably stratified wrt to the one below and above', 'none') CS%id_uheff_2d = register_diag_field('ocean_model', 'uhEff_2d', diag%axesCu1, Time, & 'Total thickness of diffusive sublayers at u-points', 'm') CS%id_vheff_2d = register_diag_field('ocean_model', 'vhEff_2d', diag%axesCv1, Time, & @@ -393,7 +385,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) integer :: i, j, k ! Variables used for reconstructions real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes - real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: stable_cell_real real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta @@ -412,8 +403,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) CS%S_i(:,:,:,:) = 0. CS%dRdT_i(:,:,:,:) = 0. CS%dRdS_i(:,:,:,:) = 0. - CS%dRdT_l(:,:,:) = 0. - CS%dRdS_l(:,:,:) = 0. CS%ns(:,:) = 0. CS%stable_cell(:,:,:) = .true. endif @@ -422,12 +411,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) CS%Pint(:,:,1) = 0. do k=1,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*GV%H_to_Pa - if (CS%ref_pres<=0.) then - P_lay = 0.5*(CS%Pint(i,j,k+1) + CS%Pint(i,j,k)) - call calculate_density_derivs(T(i,j,k), S(i,j,k), P_lay, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), CS%EOS) - else - call calculate_density_derivs(T(i,j,k), S(i,j,k), CS%ref_pres, CS%dRdT_l(i,j,k), CS%dRdS_l(i,j,k), CS%EOS) - endif enddo ; enddo ; enddo do j = G%jsc-1, G%jec+1 @@ -469,16 +452,9 @@ 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( G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%stable_cell(i,j,:), CS%ns(i,j) ) + call mark_unstable_cells( G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%stable_cell(i,j,:), CS%ns(i,j) ) enddo ; enddo - do k = 1,G%ke ; do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 - if (CS%stable_cell(i,j,k)) then - stable_cell_real(i,j,k) = 1. - else - stable_cell_real(i,j,k) = 0. - endif - enddo ; enddo ; enddo - if (CS%id_stable_cell>0) call post_data(CS%id_stable_cell, stable_cell_real, CS%diag) endif CS%uhEff(:,:,:) = 0. @@ -542,14 +518,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) if (CS%id_uhEff_2d>0) then hEff_sum(:,:) = 0. - do k = 1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc-1,G%iec + do k = 1,CS%nsurf-1 ; do j=G%jsc,G%jec ; do i=G%isc-1,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%uhEff(i,j,k) enddo ; enddo; enddo call post_data(CS%id_uhEff_2d, hEff_sum, CS%diag) endif if (CS%id_vhEff_2d>0) then hEff_sum(:,:) = 0. - do k = 1,G%ke ; do j=G%jsc-1,G%jec ; do i=G%isc,G%iec + do k = 1,CS%nsurf-1 ; do j=G%jsc-1,G%jec ; do i=G%isc,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%vhEff(i,j,k) enddo ; enddo; enddo call post_data(CS%id_vhEff_2d, hEff_sum, CS%diag) @@ -1309,6 +1285,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, dRdS_other = dRdS_l(kl_left, ki_left) ! Interpolate for the neutral surface position within the right column, layer krm1 ! Potential density difference, rho(kr-1) - rho(kl) (should be negative) + if (CS%refine_position .and. (lastK_right == kl_right)) then call drho_at_pos(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, Pres_r(kl_right), & Pres_l(kl_right+1), ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), lastP_right, dRhoTop) @@ -1375,22 +1352,25 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, endif enddo neutral_surfaces if (CS%debug) then - print *, "==========Start Neutral Surfaces==========" + write (*,*) "==========Start Neutral Surfaces==========" do k = 1,ns-1 if (hEff(k)>0.) then kl_left = KoL(k) kl_right = KoR(k) + write (*,'(A,I3,X,ES16.6,X,I3,X,ES16.6)') "Top surface KoL, PoL, KoR, PoR: ", kl_left, PoL(k), kl_right, PoR(k) call check_neutral_positions(CS%ndiff_aux_CS, Pres_l(kl_left), Pres_l(kl_left+1), Pres_r(kl_right), & Pres_r(kl_right+1), PoL(k), PoR(k), ppoly_T_l(kl_left,:), ppoly_T_r(kl_right,:), & ppoly_S_l(kl_left,:), ppoly_S_r(kl_right,:)) kl_left = KoL(k+1) kl_right = KoR(k+1) + write (*,'(A,I3,X,ES16.6,X,I3,X,ES16.6)') "Bot surface KoL, PoL, KoR, PoR: ", kl_left, PoL(k+1), kl_right, PoR(k) call check_neutral_positions(CS%ndiff_aux_CS, Pres_l(kl_left), Pres_l(kl_left+1), Pres_r(kl_right), & Pres_r(kl_right+1), PoL(k), PoR(k), ppoly_T_l(kl_left,:), ppoly_T_r(kl_right,:), & ppoly_S_l(kl_left,:), ppoly_S_r(kl_right,:)) endif enddo - print *, "==========End Neutral Surfaces==========" + write(*,'(A,E16.6)') "Total thickness of sublayers: ", SUM(hEff) + write(*,*) "==========End Neutral Surfaces==========" endif end subroutine find_neutral_surface_positions_discontinuous @@ -1506,13 +1486,6 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K aL_r(krt), aR_r(krt), Tr(krt)) dT_top = T_right_top - T_left_top dT_bottom = T_right_bottom - T_left_bottom - dT_ave = 0.5 * ( dT_top + dT_bottom ) - dT_layer = T_right_layer - T_left_layer - if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then - dT_ave = 0. - else - dT_ave = dT_layer - endif else ! Discontinuous reconstruction klb = KoL(k_sublayer+1) klt = KoL(k_sublayer) @@ -1538,9 +1511,6 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K PiR(k_sublayer), PiR(k_sublayer+1)) dT_top = T_right_top - T_left_top dT_bottom = T_right_bottom - T_left_bottom - dT_ave = T_right_layer - T_left_layer - dT_layer = Tr(klt) - Tl(krt) - dT_ave = dT_layer endif if (signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then dT_ave = 0. @@ -1549,6 +1519,13 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K endif dT_ave = dT_ave endif + dT_ave = 0.5 * ( dT_top + dT_bottom ) + dT_layer = T_right_layer - T_left_layer + if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then + dT_ave = 0. + else + dT_ave = dT_layer + endif Flx(k_sublayer) = dT_ave * hEff(k_sublayer) enddo diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index bceca444d5..4d58545acc 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -80,10 +80,6 @@ subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) stable_cell(k) = delta_rho >= 0. enddo - if (ANY(.not. stable_cell)) then - print *, "Unstable cell 1" - endif - first_stable = 1 ! Check to see that bottom interface of upper cell is lighter than the upper interface of the lower cell do k=1,nk @@ -106,9 +102,6 @@ subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) ! If the lower cell is marked as stable, then it should be the next reference cell if (stable_cell(k)) prev_stable = k enddo - if (ANY(.not. stable_cell)) then - print *, "Unstable cell 2" - endif ! Number of interfaces is the 2 times number of stable cells in the water column ns = 0 @@ -436,15 +429,15 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to endif dalpha_dS = dbeta_dT ! Cross derivatives are identicial ! By chain rule dT_dP= (dT_dz)*(dz/dP) = dT_dz / (Pbot-Ptop) - dT_dP = first_derivative_polynomial( ppoly_T, CS%nterm, refine_nondim_position ) / delta_P - dS_dP = first_derivative_polynomial( ppoly_S, CS%nterm, refine_nondim_position ) / delta_P + dT_dP = first_derivative_polynomial( ppoly_T, CS%nterm, b ) / delta_P + dS_dP = first_derivative_polynomial( ppoly_S, CS%nterm, b ) / delta_P ! Total derivative of d_delta_rho wrt P d_delta_rho_dP = 0.5*( delta_S*(dS_dP*dbeta_dS + dT_dP*dbeta_dT + dbeta_dP) + & ( delta_T*(dS_dP*dalpha_dS + dT_dP*dalpha_dT + dalpha_dP))) + & dS_dP*beta_avg + dT_dP*alpha_avg - ! This probably won't happen, but if it does nudge the value a little for the next iteration + ! This probably won't happen, but if it does take a bisection if (d_delta_rho_dP == 0.) then - b = b + 2*EPSILON(b)*b + b = 0.5*(a+c) else ! Newton step update P_int = P_int - (fb / d_delta_rho_dP) @@ -455,14 +448,11 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! Test to see if it fell out of the bracketing interval. If so, take a bisection step if (b < a .or. b > c) then b = 0.5*(a + c) - if (CS%debug) print *, "Bisection step size: ", b-b_last - else - if (CS%debug) print *, "Newton step size, f'(b): ", (fb/d_delta_rho_dP)/delta_P, d_delta_rho_dP endif endif call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & b, fb, P_int, T, S, alpha_avg, beta_avg, delta_T, delta_S) - if (CS%debug) print *, "Iteration, b, fb: ", iter, b, fb + if (CS%debug) write(*,'(A,I3.3,X,ES23.15,X,ES23.15)') "Iteration, b, fb: ", iter, b, fb if (fb < 0. .and. fb > neg_fun) then neg_fun = fb @@ -587,7 +577,6 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to write (*,*) "S, S Poly Coeffs: ", S, ppoly_S write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref - write (*,*) "P, dT_dP, dS_dP:", P_int, dT_dP, dS_dP write (*,*) "x0: ", min_bound write (*,*) "refine_nondim_position: ", refine_nondim_position endif @@ -601,7 +590,6 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to write (*,*) "S, S Poly Coeffs: ", S, ppoly_S write (*,*) "T_ref, alpha_ref: ", T_ref, alpha_ref write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref - write (*,*) "dT_dP, dS_dP:", dT_dP, dS_dP write (*,*) "x0: ", min_bound write (*,*) "refine_nondim_position: ", refine_nondim_position endif @@ -657,8 +645,7 @@ subroutine check_neutral_positions(CS, Ptop_l, Pbot_l, Ptop_r, Pbot_r, PoL, PoR, endif delta_rho = 0.5*( (alpha_l + alpha_r)*(Tl - Tr) + (beta_l + beta_r)*(Sl - Sr) ) - print *, "Delta-rho: ", delta_rho - + write(*,'(A,ES23.15)') "Delta-rho: ", delta_rho end subroutine check_neutral_positions From 718ce2a6081b4c66fbdf54252ed9cd122a773c19 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 14 Dec 2017 15:25:20 -0500 Subject: [PATCH 052/170] Option for boundary extrapolation in main remapping Boundary extrapolation was hardcoded to be false in the main remapping control structure used during the ALE regridding/remapping step. This behavior can now be controlled at runtime via REMAP_BOUNDARY_EXTRAP. --- src/ALE/MOM_ALE.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 0e269123d8..dc41cf9da1 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -159,6 +159,7 @@ subroutine ALE_init( param_file, GV, max_depth, CS) logical :: check_remapping logical :: force_bounds_in_subcell logical :: local_logical + logical :: remap_boundary_extrap if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -225,8 +226,11 @@ subroutine ALE_init( param_file, GV, max_depth, CS) "If true, the values on the intermediate grid used for remapping\n"//& "are forced to be bounded, which might not be the case due to\n"//& "round off.", default=.false.) + call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & + "If true, values at the interfaces of boundary cells are \n"//& + "extrapolated instead of piecewise constant", default=.false.) call initialize_remapping( CS%remapCS, string, & - boundary_extrapolation=.false., & + boundary_extrapolation=remap_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell) From 2d0cce2bc67aa2d760c4e9b4684c120a67012b5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:23:56 -0500 Subject: [PATCH 053/170] +(*)Only call diag_update_remap_grids if needed Added a new function, transport_remap_grid_needed, that indicates whether it is necessary to calculate the diagnostic grids for transports, and then only call diag_update_remap_grids if it is necessary. Without this change, the model will fail to run if no transports are being remapped but any other diagnostic fields are being remapped. If the model does run, all answers are bitwise identical. --- src/core/MOM.F90 | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c618a2c353..a16f51c139 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -766,7 +766,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif ! Store pre-dynamics state for proper diagnostic remapping if mass transports requested - if (CS%id_uhtr > 0 .or. CS%id_vhtr > 0 .or. CS%id_umo > 0 .or. CS%id_vmo > 0) then + if (transport_remap_grid_needed(CS)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied h_pre_dyn(i,j,k) = h(i,j,k) if (associated(CS%tv%T)) T_pre_dyn(i,j,k) = CS%tv%T(i,j,k) @@ -2746,7 +2746,8 @@ subroutine post_transport_diagnostics(G, GV, CS, diag, dt_trans, h, h_pre_dyn, T ! Post mass transports, including SGS ! Build the remap grids using the layer thicknesses from before the dynamics - call diag_update_remap_grids(diag, alt_h = h_pre_dyn, alt_T = T_pre_dyn, alt_S = S_pre_dyn) + if (transport_remap_grid_needed(CS)) & + call diag_update_remap_grids(diag, alt_h = h_pre_dyn, alt_T = T_pre_dyn, alt_S = S_pre_dyn) H_to_kg_m2_dt = GV%H_to_kg_m2 / dt_trans if (CS%id_umo_2d > 0) then @@ -2783,6 +2784,17 @@ subroutine post_transport_diagnostics(G, GV, CS, diag, dt_trans, h, h_pre_dyn, T end subroutine post_transport_diagnostics +!> Indicate whether it is necessary to save and recalculate the grid for finding +!! remapped transports. +function transport_remap_grid_needed(CS) result(needed) + type(MOM_control_struct), intent(in) :: CS !< control structure + logical :: needed + + needed = .false. + needed = needed .or. (CS%id_uhtr > 0) .or. (CS%id_vhtr > 0) + needed = needed .or. (CS%id_umo > 0) .or. (CS%id_vmo > 0) +end function transport_remap_grid_needed + !> Post diagnostics of temperatures and salinities, their fluxes, and tendencies. subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) type(MOM_control_struct), intent(inout) :: CS !< control structure From 9eb14534b31ec2547fb75b4db49373c71f6583db Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:24:42 -0500 Subject: [PATCH 054/170] Rescale thickness weighting in global means Rescaled thickness weighting in global_layer_mean and global_volume_mean to avoid overflow or underflow for extreme values of H_to_m. This does not change answers, but makes the code more robust. All answers are bitwise identical. --- src/framework/MOM_spatial_means.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 3d8120660d..15643292d1 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -73,7 +73,7 @@ function global_layer_mean(var, h, G, GV) tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight(i,j,k) = h(i,j,k) * (G%areaT(i,j) * G%mask2dT(i,j)) + weight(i,j,k) = (GV%H_to_m * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j,k) = var(i,j,k) * weight(i,j,k) enddo ; enddo ; enddo @@ -101,7 +101,7 @@ function global_volume_mean(var, h, G, GV) tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight_here = h(i,j,k) * (G%areaT(i,j) * G%mask2dT(i,j)) + weight_here = (GV%H_to_m * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j) = tmpForSumming(i,j) + var(i,j,k) * weight_here sum_weight(i,j) = sum_weight(i,j) + weight_here enddo ; enddo ; enddo From af794e66858450daff1fdc279d42824a8b9030dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:25:44 -0500 Subject: [PATCH 055/170] Changed argument name in int_density_dz_generic_plm Corrected a required argument name and comment in int_density_dz_generic_plm from H_subroundoff to dz_subroundoff to reflect the fact that the argument dz_neglect is a geometric height difference, not a thickness (in m or kg m-2 or whatever) difference. Also added a fatal argument if anyone very tries to use int_density_dz_generic_plm_analytic, which from inspection simply can not be right, but thankfully appears not to be used ever. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 36 ++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index d4604b42e3..65d80d0009 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1065,18 +1065,27 @@ end subroutine int_density_dz_generic_cell ! ========================================================================== -! Compute pressure gradient force integrals for the case where T and S -! are linear profiles. +!> Compute pressure gradient force integrals by quadrature for the case where +!! T and S are linear profiles. ! ========================================================================== subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & - rho_0, G_e, H_subroundoff, bathyT, HII, HIO, EOS, dpa, & + rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp) type(hor_index_type), intent(in) :: HII, HIO real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T_t, T_b, S_t, S_b, z_t, z_b - real, intent(in) :: rho_ref, rho_0, G_e, H_subroundoff - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), intent(in) :: bathyT + intent(in) :: T_t, T_b, S_t, S_b + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_t !< The geometric height at the top + !! of the layer, usually in m + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_b !< The geometric height at the bpttom + !! of the layer, usually in m + real, intent(in) :: rho_ref, rho_0, G_e + real, intent(in) :: dz_subroundoff !< A miniscule thickness + !! change in the same units as z_t + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: bathyT !< The depth of the bathymetry in m type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(out) :: dpa @@ -1214,8 +1223,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & hWght = massWeightingToggle * & max(0., -bathyT(iin,jin)-z_t(iin+1,jin), -bathyT(iin+1,jin)-z_t(iin,jin)) if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + H_subroundoff - hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + H_subroundoff + hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff + hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) Ttl = ( (hWght*hR)*T_t(iin+1,jin) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom @@ -1295,8 +1304,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & hWght = massWeightingToggle * & max(0., -bathyT(i,j)-z_t(iin,jin+1), -bathyT(i,j+1)-z_t(iin,jin)) if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + H_subroundoff - hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + H_subroundoff + hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff + hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom @@ -1791,6 +1800,9 @@ subroutine int_density_dz_generic_plm_analytic (T_t, T_b, S_t, S_b, z_t, & Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + call MOM_error(FATAL, "I believe that int_density_dz_generic_plm_analytic "//& + "has serious bugs and should not be used in its current form. - R. Hallberg") + GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 @@ -1828,6 +1840,10 @@ subroutine int_density_dz_generic_plm_analytic (T_t, T_b, S_t, S_b, z_t, & if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + + !### The fact that this this expression does not use T and that + !### an optional variable is assigned, even if it is not present + !### strongly suggests that this code is wrong. intz_dpa(i,j) = ( 0.5 * (S_b(i,j)+1000.0-rho_ref) + & (1.0/3.0) * dS ) * G_e * dz**2 From 0ef9f6a54672f3c6b63af7e115e8c62fe68fc077 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:28:17 -0500 Subject: [PATCH 056/170] (*)Eliminated LARGE_VAL from MOM_entrain_diffusive Replaced the hard-coded parameter LARGE_VAL inside of MOM_entrain_diffusive with an equivalent parameter that is rescaled appropriately when H_TO_M is changed. All answers are bitwise identical when H_TO_M=1, but answers can change slightly for very small values of H_TO_M. All existing test cases are bitwise identical. --- src/parameterizations/vertical/MOM_entrain_diffusive.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index b931366668..3da47e51e6 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -1740,7 +1740,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! method might be used for the next iteration. logical, dimension(SZI_(G)) :: redo_i ! If true, more work is needed on this column. logical :: do_any - real, parameter :: LARGE_VAL = 1.0e30 + real :: large_err ! A large error measure, in H2. integer :: i, it integer, parameter :: MAXIT = 30 @@ -1749,6 +1749,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & "unless BULKMIXEDLAYER is defined.") endif tolerance = GV%m_to_H * CS%Tolerance_Ent + large_err = GV%m_to_H**2 * 1.0e30 do i=is,ie ; redo_i(i) = do_i(i) ; enddo @@ -1758,7 +1759,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! These were previously calculated and provide good limits and estimates ! of the errors there. By construction the errors increase with R*ea_kbp1. E_min(i) = min_eakb(i) ; E_max(i) = max_eakb(i) - error_minE(i) = -LARGE_VAL ; error_maxE(i) = LARGE_VAL + error_minE(i) = -large_err ; error_maxE(i) = large_err false_position(i) = .true. ! Used to alternate between false_position and ! bisection when Newton's method isn't working. if (present(err_min_eakb0)) error_minE(i) = err_min_eakb0(i) - E_min(i) * ea_kbp1(i) @@ -1823,7 +1824,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! remain bracketed between Rmin and Rmax. Ent(i) = Ent(i) - err(i) / derror_dE(i) elseif (false_position(i) .and. & - (error_maxE(i) - error_minE(i) < 0.9*LARGE_VAL)) then + (error_maxE(i) - error_minE(i) < 0.9*large_err)) then ! Use the false postion method if there are decent error estimates. Ent(i) = E_min(i) + (E_max(i)-E_min(i)) * & (-error_minE(i)/(error_maxE(i) - error_minE(i))) From fc79daab87c6c467cde41b145a238d0505c7c41b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:36:02 -0500 Subject: [PATCH 057/170] (*)Corrected the calculation of MEKE%GM_src Corrected the accumulation of one of the work terms contributing to GMwork and MEKE%GM_src so that it now gives answers that are robust to changes in H_TO_M. Also corrected the units written out with 6 diagnostic diffusivities, so available_diags files will change. Answers remain unchanged if H_TO_M=1, and no test case solutions change. --- .../lateral/MOM_thickness_diffuse.F90 | 27 ++++++++++--------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b3bdf4715a..7cb8f0abcb 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1076,9 +1076,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do j=js,je ; do I=is-1,ie ; uhD(I,j,1) = -uhtot(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo ; enddo else -!$OMP parallel do default(none) shared(is,ie,js,je,pres,T,S,IsdB,tv,uhD,uhtot, & -!$OMP Work_u,G_scale,use_EOS,e) & -!$OMP private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) + !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) do j=js,je if (use_EOS) then do I=is-1,ie @@ -1096,12 +1094,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) endif - Work_u(I,j) = Work_u(I,j) + G_scale * ( (uhD(I,j,1) * drdiB) * 0.25 * & - ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) + Work_u(I,j) = Work_u(I,j) + ( G_scale * H_to_m ) * & + ( (uhD(I,j,1) * drdiB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) enddo enddo + !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB) do J=js-1,je if (use_EOS) then do i=is,ie @@ -1119,8 +1119,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdjB = drho_dT_v(i) * (T(i,j+1,1)-T(i,j,1)) + & drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1)) endif - Work_v(i,J) = Work_v(i,J) - G_scale * ( (vhD(i,J,1) * drdjB) * 0.25 * & - ((e(i,j,1) + e(i,j,2)) + (e(i,j+1,1) + e(i,j+1,2))) ) + Work_v(i,J) = Work_v(i,J) - ( G_scale * H_to_m ) * & + ( (vhD(i,J,1) * drdjB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i,j+1,1) + e(i,j+1,2))) ) enddo enddo endif @@ -1781,22 +1782,22 @@ subroutine thickness_diffuse_init(Time, G, GV, param_file, diag, CDp, CS) if (CS%id_GMwork > 0) call safe_alloc_ptr(CS%GMwork,G%isd,G%ied,G%jsd,G%jed) CS%id_KH_u = register_diag_field('ocean_model', 'KHTH_u', diag%axesCui, Time, & - 'Parameterized mesoscale eddy advection diffusivity at U-point', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at U-point', 'm2 s-1') CS%id_KH_v = register_diag_field('ocean_model', 'KHTH_v', diag%axesCvi, Time, & - 'Parameterized mesoscale eddy advection diffusivity at V-point', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at V-point', 'm2 s-1') CS%id_KH_t = register_diag_field('ocean_model', 'KHTH_t', diag%axesTL, Time, & - 'Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', 'm s-2',& + 'Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', 'm2 s-1',& cmor_field_name='diftrblo', & cmor_long_name='Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', & cmor_units='m2 s-1', & cmor_standard_name='ocean_tracer_diffusivity_due_to_parameterized_mesoscale_advection') CS%id_KH_u1 = register_diag_field('ocean_model', 'KHTH_u1', diag%axesCu1, Time, & - 'Parameterized mesoscale eddy advection diffusivity at U-points (2-D)', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at U-points (2-D)', 'm2 s-1') CS%id_KH_v1 = register_diag_field('ocean_model', 'KHTH_v1', diag%axesCv1, Time, & - 'Parameterized mesoscale eddy advection diffusivity at V-points (2-D)', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at V-points (2-D)', 'm2 s-1') CS%id_KH_t1 = register_diag_field('ocean_model', 'KHTH_t1', diag%axesT1, Time,& - 'Parameterized mesoscale eddy advection diffusivity at T-points (2-D)', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at T-points (2-D)', 'm2 s-1') CS%id_slope_x = register_diag_field('ocean_model', 'neutral_slope_x', diag%axesCui, Time, & 'Zonal slope of neutral surface', 'nondim') From 2f8599ee4f90d70a8aa01374f841b0ca12749ec2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:37:22 -0500 Subject: [PATCH 058/170] (*)Corrected the calculation of SkinBuoyFlux Corrected the unit conversion from H to m inside of the calculation of SkinBuoyFlux, so it now works properly when H_to_m is not 1. Also cleaned up this calculation to avoid the use of array syntax in calculations. This will change answers in test cases that use some variants of ePBL with H_TO_M not equal to 1, but answers do not change in existing test cases. --- src/core/MOM_forcing_type.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 566efc2b9b..1b99905538 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -873,7 +873,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, fluxes, optics, h, Temp, Salt, tv, j, dRhodT, dRhodS, start, npts, tv%eqn_of_state) ! Adjust netSalt to reflect dilution effect of FW flux - netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) * GV%H_to_m ! ppt H/s + netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! ppt H/s ! Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. From cacbdf40b19ad8d28db936eb7f6d557f88c51161 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:39:40 -0500 Subject: [PATCH 059/170] (*)Corrected the modal structure calculation Corrected the calculation of the modal structure when H_to_m is not 1. This particular code failed because remapping_core_h requires that the input and output grids use the same units. This can change answers, but does not change any of the existing test cases. --- src/diagnostics/MOM_wave_speed.F90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 1770ebb4f1..fbd0ce2daa 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -34,7 +34,7 @@ module MOM_wave_speed !! can be overridden by optional arguments. type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. - type(diag_ctrl), pointer :: diag !< Diagnostics control structure + type(diag_ctrl), pointer :: diag !< Diagnostics control structure end type wave_speed_CS contains @@ -42,9 +42,9 @@ module MOM_wave_speed !> Calculates the wave speed of the first baroclinic mode. subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & mono_N2_column_fraction, mono_N2_depth, modal_structure) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness in units of H (m or kg/m2) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed (m/s) type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed @@ -443,7 +443,10 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & else mode_struct(1:kc)=0. endif - call remapping_core_h(CS%remapping_CS, kc, Hc, mode_struct, nz, h(i,j,:), modal_structure(i,j,:)) + ! Note that remapping_core_h requires that the same units be used + ! for both the source and target grid thicknesses. + call remapping_core_h(CS%remapping_CS, kc, Hc, mode_struct, & + nz, GV%H_to_m*h(i,j,:), modal_structure(i,j,:)) endif else cg1(i,j) = 0.0 From 2c5197e8496d49adeecc48d1bda70a4cfef5b8b0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:41:25 -0500 Subject: [PATCH 060/170] Corrected Coef_x chksum scaling Corrected the rescaling of Coef_x and Coef_y when doing checksums and only report these checksums if the arrays are in use. All answers are bitwise identical. --- src/tracer/MOM_tracer_hor_diff.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 321601b61f..a09efe2b69 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -472,8 +472,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & G%HI, haloshift=0, symmetric=.true.) - call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & - G%HI, haloshift=0, symmetric=.true., scale=GV%H_to_m) + if (CS%use_neutral_diffusion) then + call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & + G%HI, haloshift=0, symmetric=.true.) + endif endif if (CS%id_khdt_x > 0) call post_data(CS%id_khdt_x, khdt_x, CS%diag) From ecdfd9678cb6d2543f41130b768aee6bdbe9aee5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:44:41 -0500 Subject: [PATCH 061/170] (*)Corrected pressure gradient thickness rescaling Changed H_subroundoff to dz_neglect in a call to int_density_dz_generic_plm, reflecting the fact that this particular argument is for an actual vertical geopotential height difference, which will not scale the same way as the internal representation of thickness. This changes answers if H_TO_M is not 1, but answers are bitwise identical in all existing test cases. --- src/core/MOM_PressureForce_analytic_FV.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 9e5e675b95..52e0b6bb93 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -471,6 +471,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p real :: I_Rho0 ! 1/Rho0. real :: G_Rho0 ! G_Earth / Rho0 in m4 s-2 kg-1. real :: Rho_ref ! The reference density in kg m-3. + real :: dz_neglect ! A minimal thickness in m, like e. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an @@ -500,6 +501,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p PRScheme = pressureReconstructionScheme(ALE_CSp) h_neglect = GV%H_subroundoff + dz_neglect = GV%H_subroundoff * GV%H_to_m I_Rho0 = 1.0/GV%Rho0 G_Rho0 = GV%g_Earth/GV%Rho0 rho_ref = CS%Rho0 @@ -617,9 +619,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p endif endif -!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e, & -!$OMP p_atm,nz,use_EOS,use_ALE,PRScheme,T_t,T_b,S_t, & -!$OMP S_b,CS,tv,tv_tmp,h,PFu,I_Rho0,h_neglect,PFv,dM)& +!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e,p_atm,nz,use_EOS,& +!$OMP use_ALE,PRScheme,T_t,T_b,S_t,S_b,CS,tv,tv_tmp, & +!$OMP h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& !$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & !$OMP Jeq_bk,ioff_bk,joff_bk,pa_bk, & !$OMP intx_pa_bk,inty_pa_bk,dpa_bk,intz_dpa_bk, & @@ -668,7 +670,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p call int_density_dz_generic_plm ( T_t(:,:,k), T_b(:,:,k), & S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, & - GV%H_subroundoff, G%bathyT, G%HI, G%Block(n), & + dz_neglect, G%bathyT, G%HI, G%Block(n), & tv%eqn_of_state, dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & useMassWghtInterp = CS%useMassWghtInterp) elseif ( PRScheme == PRESSURE_RECONSTRUCTION_PPM ) then From 2e5acb2b1c02b83fac41ad1043e187b7d7f26045 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:59:02 -0500 Subject: [PATCH 062/170] (*)Fixed a thickness unit inconsistency in ePBL Corrected an expression that combined two variables with units of H and m in ePBL. This code is only exercised with certain options for the shape of the diffusivity, and all existing test cases are bitwise identical. --- .../vertical/MOM_energetic_PBL.F90 | 23 ++++++++++--------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 91f4ce2714..6b1c14fdf7 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -638,9 +638,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & Kd(i,K) = 0.0 enddo ; enddo do i=is,ie - CS%ML_depth(i,j) = h(i,1)*GV%H_to_m - !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_m - sfc_connected(i) = .true. + CS%ML_depth(i,j) = h(i,1)*GV%H_to_m + !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_m + sfc_connected(i) = .true. enddo if (debug) then @@ -680,7 +680,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & iL_Ekman = absf(i)/U_star iL_Obukhov = buoy_flux(i,j)*vonkar/U_Star**3 - if (CS%Mstar_Mode.eq.CS%CONST_MSTAR) then + if (CS%Mstar_Mode == CS%CONST_MSTAR) then mech_TKE(i) = (dt*CS%mstar*GV%Rho0)*((U_Star**3)) conv_PErel(i) = 0.0 @@ -774,14 +774,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & if (CS%Mstar_Mode.gt.0) then ! Note the value of mech_TKE(i) now must be iterated over, so it is moved here ! First solve for the TKE to PE length scale - if (CS%MSTAR_MODE.eq.CS%MLD_o_OBUKHOV) then + if (CS%MSTAR_MODE == CS%MLD_o_OBUKHOV) then MLD_over_Stab = MLD_guess / Stab_Scale - CS%MSTAR_XINT - if ((MLD_over_Stab) .le. 0.0) then + if ((MLD_over_Stab) <= 0.0) then !Asymptote to 0 as MLD_over_Stab -> -infinity (always) MSTAR_mix = (CS%MSTAR_B*(MLD_over_Stab)+CS%MSTAR_A)**(CS%MSTAR_N) else if (CS%MSTAR_CAP>=0.) then - if (CS%MSTAR_FLATCAP .OR. (MLD_over_Stab .le.CS%MSTAR_XINT_UP)) then + if (CS%MSTAR_FLATCAP .OR. (MLD_over_Stab <= CS%MSTAR_XINT_UP)) then !If using flat cap (or if using asymptotic cap ! but within linear regime we can make use of same code) MSTAR_mix = min(CS%MSTAR_CAP, & @@ -797,10 +797,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & MSTAR_mix = CS%MSTAR_SLOPE*(MLD_over_Stab)+CS%MSTAR_AT_XINT endif endif - elseif (CS%MSTAR_MODE.eq.CS%EKMAN_o_OBUKHOV) then + elseif (CS%MSTAR_MODE == CS%EKMAN_o_OBUKHOV) then + !### Please refrain from using the construct A / B / C in place of A/(B*C). mstar_STAB = CS%MSTAR_COEF*sqrt(Bf_Stable/u_star**2/(absf(i)+1.e-10)) mstar_ROT = CS%C_EK*log(max(1.,u_star/(absf(i)+1.e-10)/mld_guess)) - if ( CS%MSTAR_CAP.le.0.0) then !No cap. + if ( CS%MSTAR_CAP <= 0.0) then !No cap. MSTAR_MIX = max(mstar_STAB,& ! 1st term if balance of rotation and stabilizing ! the balance is f(L_Ekman,L_Obukhov) min(& ! 2nd term for forced stratification limited @@ -907,7 +908,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & I_MLD = 1.0 / MLD_guess ; h_rsum = 0.0 MixLen_shape(1) = 1.0 do K=2,nz+1 - h_rsum = h_rsum + h(i,k-1) + h_rsum = h_rsum + h(i,k-1)*GV%H_to_m if (CS%MixLenExponent==2.0)then MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**2!CS%MixLenExponent @@ -1417,7 +1418,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & do k=2,nz if (FIRST_OBL) then !Breaks when OBL found if (Vstar_Used(k) > 1.e-10 .and. k < nz) then - MLD_FOUND = MLD_FOUND+h(i,k-1)*GV%H_to_m + MLD_FOUND = MLD_FOUND + h(i,k-1)*GV%H_to_m else FIRST_OBL = .false. if (MLD_FOUND-CS%MLD_tol > MLD_guess) then From 60d957e279cc5ac93cac19376319c39d02ca9dc8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:59:39 -0500 Subject: [PATCH 063/170] (*)Corrected the calculation of SkinBuoyFlux Corrected the unit conversion from H to m inside of the calculation of SkinBuoyFlux, so it now works properly when H_to_m is not 1. Also cleaned up this calculation to avoid the use of array syntax in calculations. This will change answers in test cases that use some variants of ePBL with H_TO_M not equal to 1, but answers do not change in existing test cases. --- .../vertical/MOM_diabatic_aux.F90 | 39 ++++++++++--------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index b7369d10b2..9588ac3a5c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1265,25 +1265,26 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! 1) Answers will change due to round-off ! 2) Be sure to save their values BEFORE fluxes are used. if (Calculate_Buoyancy) then - drhodt(:) = 0.0 - drhods(:) = 0.0 - netPen(:,:) = 0.0 - ! Sum over bands and attenuate as a function of depth - ! netPen is the netSW as a function of depth - call sumSWoverBands(G, GV, h2d(:,:), optics%opacity_band(:,:,j,:), nsw, j, dt, & - H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) - ! Density derivatives - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, & - dRhodT, dRhodS, start, npts, tv%eqn_of_state) - ! 1. Adjust netSalt to reflect dilution effect of FW flux - ! 2. Add in the SW heating for purposes of calculating the net - ! surface buoyancy flux affecting the top layer. - ! 3. Convert to a buoyancy flux, excluding penetrating SW heating - ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. - SkinBuoyFlux(G%isc:G%iec,j) = - GoRho * ( dRhodS(G%isc:G%iec) * (netSalt_rate(G%isc:G%iec) & - - tv%S(G%isc:G%iec,j,1) * netMassInOut_rate(G%isc:G%iec)* GV%H_to_m )& - + dRhodT(G%isc:G%iec) * ( netHeat_rate(G%isc:G%iec) + & - netPen(G%isc:G%iec,1))) * GV%H_to_m ! m^2/s^3 + drhodt(:) = 0.0 + drhods(:) = 0.0 + netPen(:,:) = 0.0 + ! Sum over bands and attenuate as a function of depth + ! netPen is the netSW as a function of depth + call sumSWoverBands(G, GV, h2d(:,:), optics%opacity_band(:,:,j,:), nsw, j, dt, & + H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) + ! Density derivatives + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, & + dRhodT, dRhodS, start, npts, tv%eqn_of_state) + ! 1. Adjust netSalt to reflect dilution effect of FW flux + ! 2. Add in the SW heating for purposes of calculating the net + ! surface buoyancy flux affecting the top layer. + ! 3. Convert to a buoyancy flux, excluding penetrating SW heating + ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. + do i=is,ie + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_m * ( & + dRhodS(i) * (netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dRhodT(i) * ( netHeat_rate(i) + netPen(i,1)) ) ! m^2/s^3 + enddo endif enddo ! j-loop finish From 1dddb0e6c81226e8749226269362d711c8d7aeb8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 17:00:14 -0500 Subject: [PATCH 064/170] (*)Changed the value for miniscule TKE in bulk ML Changed the value for a tiny amount of TKE from 1e-300 to 1e-150 to avoid underflow when H_to_m is much less than 1 in one sensitivity calculation as a part of an iteration in the mechanical entrainment portion of the bulk mixed layer code. This does not change any answer in existing test cases. --- .../vertical/MOM_bulk_mixed_layer.F90 | 38 ++++++++----------- 1 file changed, 16 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 29e65e9a32..7b2b39f242 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -76,7 +76,7 @@ module MOM_bulk_mixed_layer ! released mean kinetic energy becomes TKE, nondim. real :: Hmix_min ! The minimum mixed layer thickness in m. real :: H_limit_fluxes ! When the total ocean depth is less than this - ! value, in H, scale away all surface forcing to + ! value, in m, scale away all surface forcing to ! avoid boiling the ocean. real :: ustar_min ! A minimum value of ustar to avoid numerical ! problems, in m s-1. If the value is small enough, @@ -433,6 +433,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & integer :: i, j, k, is, ie, js, je, nz, nkmb, n integer :: nsw ! The number of bands of penetrating shortwave radiation. + real :: H_limit_fluxes ! CS%H_limit fluxes converted to units of H. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_mixed_layer: "//& @@ -451,13 +453,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & Irho0 = 1.0 / GV%Rho0 dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag - Idt = 1.0/dt + Idt = 1.0 / dt Idt_diag = 1.0 / dt__diag write_diags = .true. ; if (present(last_call)) write_diags = last_call + H_limit_fluxes = CS%H_limit_fluxes * GV%m_to_H p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref - nsw = CS%nsw if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then @@ -522,21 +524,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & endif max_BL_det(:) = -1 -!$OMP parallel default(none) shared(is,ie,js,je,nz,h_3d,u_3d,v_3d,nkmb,G,GV,nsw,optics, & -!$OMP CS,tv,fluxes,Irho0,dt,Idt_diag,Ih,write_diags, & -!$OMP hmbl_prev,h_sum,Hsfc_min,Hsfc_max,dt__diag, & -!$OMP Hsfc_used,Inkmlm1,Inkml,ea,eb,h_miss,Hml, & -!$OMP id_clock_EOS,id_clock_resort,id_clock_adjustment, & -!$OMP id_clock_conv,id_clock_mech,id_clock_detrain,aggregate_FW_forcing ) & -!$OMP firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & -!$OMP private(h,h_orig,u,v,eps,T,S,opacity_band,d_ea,d_eb, & -!$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,R0,Rcv,ksort, & -!$OMP RmixConst,TKE_river,netMassInOut, NetMassOut, & -!$OMP Net_heat, Net_salt, htot,TKE,Pen_SW_bnd,Ttot,Stot, uhtot,& -!$OMP vhtot, R0_tot, Rcv_tot,Conv_en,dKE_FC,Idecay_len_TKE, & -!$OMP cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star,absf_x_H, & -!$OMP ebml,eaml) -!$OMP do + !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & + !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & + !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,htot,Ttot,Stot,TKE,Conv_en, & + !$OMP RmixConst,TKE_river,Pen_SW_bnd,netMassInOut,NetMassOut, & + !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,dKE_FC, & + !$OMP Idecay_len_TKE,cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star, & + !$OMP absf_x_H,ebml,eaml) + !$OMP do do j=js,je ! Copy the thicknesses and other fields to 2-d arrays. do k=1,nz ; do i=is,ie @@ -626,7 +621,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! net_salt = salt ( g(salt)/m2 for non-Bouss and ppt*m/s for Bouss ) via surface fluxes ! Pen_SW_bnd = components to penetrative shortwave radiation call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & - CS%H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & + H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h(:,1:), T(:,1:), netMassInOut, netMassOut, Net_heat, Net_salt, Pen_SW_bnd,& tv, aggregate_FW_forcing) @@ -660,7 +655,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & cMKE, Idt_diag, nsw, Pen_SW_bnd, opacity_band, TKE, & Idecay_len_TKE, j, ksort, G, GV, CS) - call absorbRemainingSW(G, GV, h(:,1:), opacity_band, nsw, j, dt, CS%H_limit_fluxes, & + call absorbRemainingSW(G, GV, h(:,1:), opacity_band, nsw, j, dt, H_limit_fluxes, & CS%correct_absorption, CS%absorb_all_SW, & T(:,1:), Pen_SW_bnd, eps, ksort, htot, Ttot) @@ -1824,7 +1819,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif TKE(i) = TKE_full_ent - if (TKE(i) <= 0.0) TKE(i) = 1e-300 + if (TKE(i) <= 0.0) TKE(i) = 1.0e-150 else ! The layer is only partially entrained. The amount that will be ! entrained is determined iteratively. No further layers will be @@ -3736,7 +3731,6 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) "The surface fluxes are scaled away when the total ocean \n"//& "depth is less than DEPTH_LIMIT_FLUXES.", & units="m", default=0.1*CS%Hmix_min) - CS%H_limit_fluxes = CS%H_limit_fluxes * GV%m_to_H call get_param(param_file, mdl, "OMEGA",CS%omega, & "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) From 918ae3f5849cc991f8a8c6e05d057d4eece4c7ae Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 20:29:54 -0500 Subject: [PATCH 065/170] +Added optional h_neglect arguments to remapping code Added new optional arguments for the thicknesses to neglect to all of the remapping code where a neglected thickness is used. The subroutines that were changed include: remapping_core_h, remapping_core_w, build_reconstructions_1d, {PCM, PLM,PPM,PQM}_reconstruction, {PLM,PPM}_boundary_extrapolation, edge_values_..., edge_slopes_..., build_and_interpolate_grid, remapByProjection, remapByDeltaZ, integrateReconOnInterval, build_{rho,hycom1,SLight}_column, and build_rho_column_iteratively. The internal work routines P3M_interpolation and {PPM,P3M}_limiter have new required arguments. Also, to accomodate the new optional h_neglect arguments, internally h_neglect was renamed hNeglect in many places. This change will enable this code to reproduce across changes in the internal representation of thickness, once the optional arguments are used. All answers are bitwise identical. --- src/ALE/MOM_remapping.F90 | 314 +++++++++++++++++++++------------ src/ALE/P1M_functions.F90 | 19 +- src/ALE/P3M_functions.F90 | 107 ++++++----- src/ALE/PLM_functions.F90 | 36 ++-- src/ALE/PPM_functions.F90 | 51 +++--- src/ALE/PQM_functions.F90 | 138 ++++++++------- src/ALE/coord_hycom.F90 | 20 ++- src/ALE/coord_rho.F90 | 47 +++-- src/ALE/coord_slight.F90 | 24 ++- src/ALE/regrid_edge_slopes.F90 | 109 +++++++----- src/ALE/regrid_edge_values.F90 | 134 ++++++++------ src/ALE/regrid_interp.F90 | 206 +++++++++++---------- 12 files changed, 737 insertions(+), 468 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 6e404ff2dd..a7879ae063 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -71,7 +71,7 @@ module MOM_remapping ! outside of the range 0 to 1. #define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -real, parameter :: h_neglect = 1.E-30 !< A dimensional (H units) number that can be +real, parameter :: hNeglect_dflt = 1.E-30 !< A dimensional (H units) number that can be !! added to thicknesses in a denominator without !! changing the numerical result, except where !! a division by zero would otherwise occur. @@ -179,7 +179,7 @@ end function isPosSumErrSignificant !> Remaps column of values u0 on grid h0 to grid h1 !! assuming the top edge is aligned. -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1) +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid @@ -187,6 +187,12 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1) integer, intent(in) :: n1 !< Number of cells on target grid real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value + !! calculations in the same units as h0. ! Local variables integer :: iMethod real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial @@ -194,8 +200,13 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1) real, dimension(n0,CS%degree+1) :: ppoly_r_coefficients !Coefficients of polynomial integer :: k real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err + real :: hNeglect, hNeglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod ) + hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod, & + hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & CS%boundary_extrapolation, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) @@ -244,14 +255,20 @@ end subroutine remapping_core_h !> Remaps column of values u0 on grid h0 to implied grid h1 !! where the interfaces of h1 differ from those of h0 by dx. -subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) +subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_edge ) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid integer, intent(in) :: n1 !< Number of cells on target grid - real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid + real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value + !! calculations in the same units as h0. ! Local variables integer :: iMethod real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial @@ -261,8 +278,13 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) real :: eps, h0tot, h0err, h1tot, h1err real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err real, dimension(n1) :: h1 !< Cell widths on target grid + real :: hNeglect, hNeglect_edge + + hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod ) + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod,& + hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & CS%boundary_extrapolation, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) @@ -277,8 +299,8 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) enddo call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, h1, iMethod, & CS%force_bounds_in_subcell,u1, uh_err ) -! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, dx, iMethod, u1 ) -! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1 ) +! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, dx, iMethod, u1, hNeglect ) +! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) if (CS%check_remapping) then ! Check errors and bounds @@ -319,15 +341,24 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) end subroutine remapping_core_w !> Creates polynomial reconstructions of u0 on the source grid h0. -subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod ) - type(remapping_CS), intent(in) :: CS - integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - real, dimension(n0,CS%degree+1), intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial - integer, intent(out) :: iMethod !< Integration method +subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & + ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & + h_neglect_edge ) + type(remapping_CS), intent(in) :: CS + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0,CS%degree+1), & + intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial + real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial + integer, intent(out) :: iMethod !< Integration method + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value + !! calculations in the same units as h0. ! Local variables integer :: local_remapping_scheme integer :: remapping_scheme !< Remapping scheme @@ -352,39 +383,41 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefficients) iMethod = INTEGRATION_PCM case ( REMAPPING_PLM ) - call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients) + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect) end if iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) - call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E ) - call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & + ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) - call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E ) - call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & + ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PQM case default @@ -468,7 +501,7 @@ end subroutine check_reconstructions_1d !> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating !! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the -!! appropriate integrals into the h1*u1 values. +!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, method, & force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) integer, intent(in) :: n0 !< Number of cells in source grid @@ -1042,7 +1075,8 @@ end subroutine measure_output_bounds !> Remaps column of values u0 on grid h0 to grid h1 by integrating !! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, method, u1 ) +subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + n1, h1, method, u1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid widths (size n0) real, intent(in) :: u0(:) !< Source cell averages (size n0) @@ -1052,6 +1086,9 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, real, intent(in) :: h1(:) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use real, intent(out) :: u1(:) !< Target cell averages (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: iTarget real :: xL, xR ! coordinates of target cell edges @@ -1070,7 +1107,7 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, xR = xL + h1(iTarget) call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & - xL, xR, h1(iTarget), u1(iTarget), jStart, xStart ) + xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) end do ! end iTarget loop on target grid cells @@ -1086,7 +1123,8 @@ end subroutine remapByProjection !! where !! F(k) = dx1(k) qAverage !! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, method, u1, h1 ) +subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & + method, u1, h1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid widths (size n0) real, intent(in) :: u0(:) !< Source cell averages (size n0) @@ -1097,6 +1135,9 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, me integer :: method !< Remapping scheme to use real, intent(out) :: u1(:) !< Target cell averages (size n1) real, optional, intent(out) :: h1(:) !< Target grid widths (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: iTarget real :: xL, xR ! coordinates of target cell edges @@ -1161,7 +1202,7 @@ end subroutine remapByDeltaZ !> Integrate the reconstructed column profile over a single cell subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & - xL, xR, hC, uAve, jStart, xStart ) + xL, xR, hC, uAve, jStart, xStart, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid sizes (size n0) real, intent(in) :: u0(:) !< Source cell averages @@ -1175,6 +1216,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, !< On exit, contains index of last cell used real, intent(inout) :: xStart !< The left edge position of cell jStart !< On first entry should be 0. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: j, k integer :: jL, jR ! indexes of source cells containing target @@ -1187,8 +1231,11 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, real :: hAct ! The distance actually used in the integration ! (notionally xR - xL) which differs due to roundoff. real :: x0_2, x1_2, x02px12, x0px1 ! Used in evaluation of integrated polynomials + real :: hNeglect ! A negligible thicness in the same units as h. real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + q = -1.E30 x0jLl = -1.E30 x0jRl = -1.E30 @@ -1240,7 +1287,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) else ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA - xi0 = xL / ( h0(jL) + h_neglect ) - x0jLl / ( h0(jL) + h_neglect ) + xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) select case ( method ) case ( INTEGRATION_PCM ) @@ -1299,11 +1346,11 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! ! Determine normalized coordinates #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) - xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + h_neglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + hNeglect ) ) ) #else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) + xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) + xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) #endif hAct = h0(jL) * ( xi1 - xi0 ) @@ -1355,9 +1402,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! Integrate from xL up to right boundary of cell jL #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) #else - xi0 = (xL - x0jLl) / ( h0(jL) + h_neglect ) + xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) #endif xi1 = 1.0 @@ -1401,9 +1448,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! Integrate from left boundary of cell jR up to xR xi0 = 0.0 #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + h_neglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + hNeglect ) ) ) #else - xi1 = (xR - x0jRl) / ( h0(jR) + h_neglect ) + xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) #endif hAct = hAct + h0(jR) * ( xi1 - xi0 ) @@ -1557,10 +1604,12 @@ logical function remapping_unit_tests(verbose) type(remapping_CS) :: CS !< Remapping control structure real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefficients integer :: i - real :: err + real :: err, h_neglect, h_neglect_edge logical :: thisTest, v v = verbose + h_neglect = hNeglect_dflt + h_neglect_edge = 1.0e-10 write(*,*) '==== MOM_remapping: remapping_unit_tests =================' remapping_unit_tests = .false. ! Normally return false @@ -1587,7 +1636,7 @@ logical function remapping_unit_tests(verbose) if (verbose) call dumpGrid(n0,h0,x0,u0) call dzFromH1H2( n0, h0, n1, h1, dx1 ) - call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1 ) + call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) do i=1,n1 err=u1(i)-8.*(0.5*real(1+n1)-real(i)) if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. @@ -1606,12 +1655,12 @@ logical function remapping_unit_tests(verbose) ppoly0_S(:,:) = 0.0 ppoly0_coefficients(:,:) = 0.0 - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefficients ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10 ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) u1(:) = 0. call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & - n1, h1, INTEGRATION_PPM, u1 ) + n1, h1, INTEGRATION_PPM, u1, h_neglect ) do i=1,n1 err=u1(i)-8.*(0.5*real(1+n1)-real(i)) if (abs(err)>2.*epsilon(err)) thisTest = .true. @@ -1623,7 +1672,7 @@ logical function remapping_unit_tests(verbose) u1(:) = 0. call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & n1, x1-x0(1:n1+1), & - INTEGRATION_PPM, u1, hn1 ) + INTEGRATION_PPM, u1, hn1, h_neglect ) if (verbose) write(*,*) 'h1 (by delta)' if (verbose) call dumpGrid(n1,h1,x1,u1) hn1=hn1-h1 @@ -1640,7 +1689,7 @@ logical function remapping_unit_tests(verbose) dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & n2, dx2, & - INTEGRATION_PPM, u2, hn2 ) + INTEGRATION_PPM, u2, hn2, h_neglect ) if (verbose) write(*,*) 'h2' if (verbose) call dumpGrid(n2,h2,x2,u2) if (verbose) write(*,*) 'hn2' @@ -1683,72 +1732,119 @@ logical function remapping_unit_tests(verbose) allocate(ppoly0_E(5,2)) allocate(ppoly0_S(5,2)) - call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,4./), 'PCM: P0') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,5./), 'Unlim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Unlim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,1.,7./), 'Left lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Left lim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,5.,7./), 'Right lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Right lim PLM: P1') - - call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E ) + call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:) ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,4./), 'PCM: P0') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + + call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + + call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & + h_neglect=1e-10 ) thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') ! Currently fails due to roundoff thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') ! Currently fails due to roundoff ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) - call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), ppoly0_coefficients(1:5,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E ) + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & + ppoly0_coefficients(1:5,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + + call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & + h_neglect=1e-10 ) thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') ! Currently fails due to roundoff thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') ! Currently fails due to roundoff ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) - call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), ppoly0_coefficients(1:5,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & + ppoly0_coefficients(1:5,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) - call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), ppoly0_coefficients(1:5,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') - - call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), ppoly0_coefficients(1:4,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') - call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), ppoly0_coefficients(1:4,:), & + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & + ppoly0_coefficients(1:5,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + + call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & + ppoly0_coefficients(1:4,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') + call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & + ppoly0_coefficients(1:4,:), & 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index 5873c6c440..a7a7635800 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -41,7 +41,7 @@ module P1M_functions !------------------------------------------------------------------------------ ! p1m interpolation !------------------------------------------------------------------------------ -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients ) +subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! ------------------------------------------------------------------------------ ! Linearly interpolate between edge values. ! The resulting piecewise interpolant is stored in 'ppoly'. @@ -57,18 +57,23 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients ) ! ------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coefficients !< Potentially modified + !! piecewise polynomial coefficients, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! loop index real :: u0_l, u0_r ! edge values (left and right) ! Bound edge values (routine found in 'edge_values.F90') - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, h_neglect ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 7e8c16a9d0..ecc7136ead 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -22,14 +22,16 @@ module P3M_functions public P3M_interpolation public P3M_boundary_extrapolation -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 +real, parameter :: hNeglect_edge_dflt = 1.E-10 contains !------------------------------------------------------------------------------ ! p3m interpolation ! ----------------------------------------------------------------------------- -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & + h_neglect ) !------------------------------------------------------------------------------ ! Cubic interpolation between edges. ! @@ -47,7 +49,9 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Call the limiter for p3m, which takes care of everything from ! computing the coefficients of the cubic to monotonizing it. @@ -55,7 +59,7 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) + call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) end subroutine P3M_interpolation @@ -63,7 +67,7 @@ end subroutine P3M_interpolation !------------------------------------------------------------------------------ ! p3m limiter ! ----------------------------------------------------------------------------- -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! The p3m limiter operates as follows: ! @@ -84,25 +88,29 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - -! real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables - integer :: k ! loop index - integer :: monotonic ! boolean indicating whether the cubic is monotonic - real :: u0_l, u0_r ! edge values - real :: u1_l, u1_r ! edge slopes - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r ! left, center and right cell widths - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes - real :: slope ! retained PLM slope - real :: eps + integer :: k ! loop index + integer :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0_l, u0_r ! edge values + real :: u1_l, u1_r ! edge slopes + real :: u_l, u_c, u_r ! left, center and right cell averages + real :: h_l, h_c, h_r ! left, center and right cell widths + real :: sigma_l, sigma_c, sigma_r ! left, center and right + ! van Leer slopes + real :: slope ! retained PLM slope + real :: eps + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, hNeglect ) ! 2. Systematically average discontinuous edge values call average_discontinuous_edge_values( N, ppoly_E ) @@ -142,9 +150,9 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) end if ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) if ( (sigma_l * sigma_r) .GT. 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -154,12 +162,12 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) ! If the slopes are close to zero in machine precision and in absolute ! value, we set the slope to zero. This prevents asymmetric representation - ! near extrema. - if ( abs(u1_l*h_c) .LT. eps ) then + ! near extrema. These expressions are both nondimensional. + if ( abs(u1_l*h_c) < eps ) then u1_l = 0.0 end if - if ( abs(u1_r*h_c) .LT. eps ) then + if ( abs(u1_r*h_c) < eps ) then u1_r = 0.0 end if @@ -201,7 +209,8 @@ end subroutine P3M_limiter !------------------------------------------------------------------------------ ! p3m boundary extrapolation ! ----------------------------------------------------------------------------- -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & + h_neglect, h_neglect_edge ) !------------------------------------------------------------------------------ ! The following explanations apply to the left boundary cell. The same ! reasoning holds for the right boundary cell. @@ -222,25 +231,33 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of finding edge values + !! in the same units as h. ! Local variables - integer :: i0, i1 - integer :: monotonic - real :: u0, u1 - real :: h0, h1 - real :: b, c, d - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: eps - real :: slope - - eps = 1e-10 + integer :: i0, i1 + integer :: monotonic + real :: u0, u1 + real :: h0, h1 + real :: b, c, d + real :: u0_l, u0_r + real :: u1_l, u1_r + real :: slope + real :: hNeglect, hNeglect_edge + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = hNeglect_edge_dflt + if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge ! ----- Left boundary ----- i0 = 1 i1 = 2 - h0 = h(i0) + eps - h1 = h(i1) + eps + h0 = h(i0) + hNeglect_edge + h1 = h(i1) + hNeglect_edge u0 = u(i0) u1 = u(i1) @@ -250,7 +267,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x ! Limit the right slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h0 + h_neglect ) + slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) if ( abs(u1_r) .GT. abs(slope) ) then u1_r = slope end if @@ -263,7 +280,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! edge value and slope by computing the parabola as determined by ! the right edge value and slope and the boundary cell average u0_l = 3.0 * u0 + 0.5 * h0*u1_r - 2.0 * u0_r - u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + h_neglect ) + u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + hNeglect ) ! Check whether the edge values are monotonic. For example, if the left edge ! value is larger than the right edge value while the slope is positive, the @@ -297,8 +314,8 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! ----- Right boundary ----- i0 = N-1 i1 = N - h0 = h(i0) + eps - h1 = h(i1) + eps + h0 = h(i0) + hNeglect_edge + h1 = h(i1) + hNeglect_edge u0 = u(i0) u1 = u(i1) @@ -307,10 +324,10 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici b = ppoly_coefficients(i0,2) c = ppoly_coefficients(i0,3) d = ppoly_coefficients(i0,4) - u1_l = (b + 2*c + 3*d) / ( h0 + h_neglect ) ! derivative evaluated at xi = 1.0 + u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 ! Limit the left slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h1 + h_neglect ) + slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) if ( abs(u1_l) .GT. abs(slope) ) then u1_l = slope end if @@ -323,7 +340,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! edge value and slope by computing the parabola as determined by ! the left edge value and slope and the boundary cell average u0_r = 3.0 * u1 - 0.5 * h1*u1_l - 2.0 * u0_l - u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + h_neglect ) + u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + hNeglect ) ! Check whether the edge values are monotonic. For example, if the right edge ! value is smaller than the left edge value while the slope is positive, the diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 24efc5dfff..83eea1518b 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -16,14 +16,14 @@ module PLM_functions public PLM_reconstruction, PLM_boundary_extrapolation -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 contains !------------------------------------------------------------------------------ ! PLM_reconstruction ! ----------------------------------------------------------------------------- -subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) +subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within each cell. ! @@ -43,6 +43,9 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) real, dimension(:), intent(in) :: u ! cell averages (size N) real, dimension(:,:), intent(inout) :: ppoly_E real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -55,6 +58,9 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) real :: u_min, u_max, e_l, e_r, edge real :: almost_one, almost_two real, dimension(N) :: slp, mslp + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect almost_one = 1. - epsilon(slope) almost_two = 2. * almost_one @@ -67,7 +73,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) ! Get cell widths h_l = h(k-1) ; h_c = h(k) ; h_r = h(k+1) - h_cn = max( h_c, h_neglect ) ! To avoid division by zero + h_cn = max( h_c, hNeglect ) ! To avoid division by zero ! Side differences sigma_r = u_r - u_c @@ -83,7 +89,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) ! This is the original estimate of the second order slope from Laurent ! but multiplied by h_c - sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + hNeglect) ) if ( (sigma_l * sigma_r) > 0.0 ) then ! This limits the slope so that the edge values are bounded by the @@ -209,7 +215,7 @@ end subroutine PLM_reconstruction !------------------------------------------------------------------------------ ! plm boundary extrapolation ! ----------------------------------------------------------------------------- -subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) +subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within boundary cells. ! The left and right edge values in the left and right boundary cells, @@ -233,17 +239,23 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) real, dimension(:), intent(in) :: u ! cell averages (size N) real, dimension(:,:), intent(inout) :: ppoly_E real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths - real :: slope ! retained PLM slope + real :: u0, u1 ! cell averages + real :: h0, h1 ! corresponding cell widths + real :: slope ! retained PLM slope + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----------------------------------------- ! Left edge value in the left boundary cell ! ----------------------------------------- - h0 = h(1) + h_neglect - h1 = h(2) + h_neglect + h0 = h(1) + hNeglect + h1 = h(2) + hNeglect u0 = u(1) u1 = u(2) @@ -264,8 +276,8 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! ------------------------------------------ ! Right edge value in the left boundary cell ! ------------------------------------------ - h0 = h(N-1) + h_neglect - h1 = h(N) + h_neglect + h0 = h(N-1) + hNeglect + h1 = h(N) + hNeglect u0 = u(N-1) u1 = u(N) diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 24205c32a1..4dd6699722 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -20,23 +20,25 @@ module PPM_functions !! to avoid division by zero. !! @note This is a dimensional parameter and should really include a unit !! conversion. -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients) +subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths real, dimension(N), intent(in) :: u !< Cell averages real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values real, dimension(N,3), intent(inout) :: ppoly_coefficients !< Polynomial coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! Loop index real :: edge_l, edge_r ! Edge values (left and right) ! PPM limiter - call PPM_limiter_standard( N, h, u, ppoly_E ) + call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) ! Loop over all cells do k = 1,N @@ -56,11 +58,14 @@ end subroutine PPM_reconstruction !> Adjusts edge values using the standard PPM limiter (Colella & Woodward, JCP 1984) !! after first checking that the edge values are bounded by neighbors cell averages !! and that the edge values are monotonic between cell averages. -subroutine PPM_limiter_standard( N, h, u, ppoly_E ) - integer, intent(in) :: N ! Number of cells - real, dimension(N), intent(in) :: h ! Cell widths - real, dimension(N), intent(in) :: u ! Cell averages - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values +subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! Loop index real :: u_l, u_c, u_r ! Cell averages (left, center and right) @@ -68,7 +73,7 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E ) real :: expr1, expr2 ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, h_neglect ) ! Make discontinuous edge values monotonic call check_discontinuous_edge_values( N, u, ppoly_E ) @@ -124,7 +129,7 @@ end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ ! ppm boundary extrapolation ! ----------------------------------------------------------------------------- -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) +subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -155,16 +160,22 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) real, dimension(:), intent(in) :: u ! cell averages (size N) real, dimension(:,:), intent(inout) :: ppoly_E real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables - integer :: i0, i1 - real :: u0, u1 - real :: h0, h1 - real :: a, b, c - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: slope - real :: exp1, exp2 + integer :: i0, i1 + real :: u0, u1 + real :: h0, h1 + real :: a, b, c + real :: u0_l, u0_r + real :: u1_l, u1_r + real :: slope + real :: exp1, exp2 + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary ----- i0 = 1 @@ -177,7 +188,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system b = ppoly_coefficients(i1,2) - u1_r = b *((h0+h_neglect)/(h1+h_neglect)) ! derivative evaluated at xi = 0.0, + u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope @@ -231,7 +242,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) b = ppoly_coefficients(i0,2) c = ppoly_coefficients(i0,3) u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 - u1_l = u1_l * ((h1+h_neglect)/(h0+h_neglect)) + u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index e4fc03092c..707cd9f40f 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -17,14 +17,14 @@ module PQM_functions public PQM_reconstruction, PQM_boundary_extrapolation, PQM_boundary_extrapolation_v1 -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 contains !------------------------------------------------------------------------------ ! PQM_reconstruction ! ----------------------------------------------------------------------------- -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by quartic polynomials within each cell. ! @@ -43,6 +43,9 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -52,7 +55,7 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real :: a, b, c, d, e ! parabola coefficients ! PQM limiter - call PQM_limiter( N, h, u, ppoly_E, ppoly_S ) + call PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! Loop on cells to construct the cubic within each cell do k = 1,N @@ -86,7 +89,7 @@ end subroutine PQM_reconstruction !------------------------------------------------------------------------------ ! Limit pqm ! ----------------------------------------------------------------------------- -subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) +subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) !------------------------------------------------------------------------------ ! Standard PQM limiter (White & Adcroft, JCP 2008). ! @@ -99,31 +102,38 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Potentially modified edge slopes, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables - integer :: k ! loop index - integer :: inflexion_l - integer :: inflexion_r - real :: u0_l, u0_r ! edge values - real :: u1_l, u1_r ! edge slopes - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r ! left, center and right cell widths - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes - real :: slope ! retained PLM slope - real :: a, b, c, d, e - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 + integer :: k ! loop index + integer :: inflexion_l + integer :: inflexion_r + real :: u0_l, u0_r ! edge values + real :: u1_l, u1_r ! edge slopes + real :: u_l, u_c, u_r ! left, center and right cell averages + real :: h_l, h_c, h_r ! left, center and right cell widths + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes + real :: slope ! retained PLM slope + real :: a, b, c, d, e + real :: alpha1, alpha2, alpha3 + real :: rho, sqrt_rho + real :: gradient1, gradient2 + real :: x1, x2 + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, hNeglect ) ! Make discontinuous edge values monotonic (thru averaging) call check_discontinuous_edge_values( N, u, ppoly_E ) @@ -152,9 +162,9 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) u_r = u(k+1) ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) if ( (sigma_l * sigma_r) .GT. 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -292,8 +302,8 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + h_neglect ) - u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + h_neglect ) + u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + hNeglect ) + u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + hNeglect ) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -303,13 +313,13 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) u1_l = 0.0 u0_r = 5.0 * u_c - 4.0 * u0_l - u1_r = 20.0 * (u_c - u0_l) / ( h_c + h_neglect ) + u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) else if ( u1_r * slope .LT. 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + h_neglect) + u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) end if @@ -317,8 +327,8 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge - u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + h_neglect) - u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + h_neglect) + u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + hNeglect) + u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + hNeglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -328,13 +338,13 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) u1_l = 0.0 u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 - u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + h_neglect) + u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) else if ( u1_r * slope .LT. 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r - u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + h_neglect) + u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) end if @@ -520,7 +530,7 @@ end subroutine PQM_boundary_extrapolation !------------------------------------------------------------------------------ ! pqm boundary extrapolation using rational function ! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -550,23 +560,29 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables - integer :: i0, i1 - integer :: inflexion_l - integer :: inflexion_r - real :: u0, u1, um - real :: h0, h1 - real :: a, b, c, d, e - real :: ar, br, beta - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: u_plm - real :: slope - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 + integer :: i0, i1 + integer :: inflexion_l + integer :: inflexion_r + real :: u0, u1, um + real :: h0, h1 + real :: a, b, c, d, e + real :: ar, br, beta + real :: u0_l, u0_r + real :: u1_l, u1_r + real :: u_plm + real :: slope + real :: alpha1, alpha2, alpha3 + real :: rho, sqrt_rho + real :: gradient1, gradient2 + real :: x1, x2 + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary (TOP) ----- i0 = 1 @@ -579,7 +595,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Compute real slope and express it w.r.t. local coordinate system ! within boundary cell - slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + h_neglect ) + slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + hNeglect ) slope = slope * h0 ! The right edge value and slope of the boundary cell are taken to be the @@ -588,12 +604,12 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff b = ppoly_coefficients(i1,2) u0_r = a ! edge value - u1_r = b / (h1 + h_neglect) ! edge slope (w.r.t. global coord.) + u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and right ! edge value and slope if (u1_r.ne.0.) then ! HACK by AJA - beta = 2.0 * ( u0_r - um ) / ( (h0 + h_neglect)*u1_r) - 1.0 + beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 else beta = 0. endif ! HACK by AJA @@ -612,10 +628,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! compute corresponding slope. if ( abs(um-u0_l) .lt. abs(um-u_plm) ) then u1_l = 2.0 * ( br - ar*beta) - u1_l = u1_l / (h0 + h_neglect) + u1_l = u1_l / (h0 + hNeglect) else u0_l = u_plm - u1_l = slope / (h0 + h_neglect) + u1_l = slope / (h0 + hNeglect) end if ! Monotonize quartic @@ -673,8 +689,8 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + h_neglect) - u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + h_neglect) + u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + hNeglect) + u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + hNeglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -684,13 +700,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff u1_l = 0.0 u0_r = 5.0 * um - 4.0 * u0_l - u1_r = 20.0 * (um - u0_l) / ( h0 + h_neglect ) + u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) else if ( u1_r * slope .LT. 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + h_neglect ) + u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) end if diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 64189869c7..b3d2ba3238 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -93,20 +93,30 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, inter end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, z_col, z_col_new) +subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & + z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive in H) real, dimension(nz), intent(in) :: T, S !< T and S for column - real, dimension(nz), intent(in) :: h !< Layer thicknesses, in m + real, dimension(nz), intent(in) :: h !< Layer thicknesses, (in m or H) real, dimension(nz), intent(in) :: p_col !< Layer pressure in Pa real, dimension(nz+1), intent(in) :: z_col ! Interface positions relative to the surface in H units (m or kg m-2) real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces + real, optional, intent(in) :: zScale !< Scaling factor from the input thicknesses in m + !! to desired units for zInterface, perhaps m_to_H. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. ! Local variables integer :: k real, dimension(nz) :: rho_col, h_col_new ! Layer quantities + real :: z_scale real :: stretching ! z* stretching, converts z* to z. real :: nominal_z ! Nominal depth of interface is using z* (m or Pa) real :: hNew @@ -116,6 +126,8 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, z_co maximum_depths_set = allocated(CS%max_interface_depths) maximum_h_set = allocated(CS%max_layer_thickness) + z_scale = 1.0 ; if (present(zScale)) z_scale = zScale + ! Work bottom recording potential density call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state) ! This ensures the potential density profile is monotonic @@ -127,14 +139,14 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, z_co ! Interpolates for the target interface position with the rho_col profile ! Based on global density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & - CS%target_density, nz, h_col_new, z_col_new) + CS%target_density, nz, h_col_new, z_col_new, h_neglect, h_neglect_edge) ! Sweep down the interfaces and make sure that the interface is at least ! as deep as a nominal target z* grid nominal_z = 0. stretching = z_col(nz+1) / depth ! Stretches z* to z do k = 2, nz+1 - nominal_z = nominal_z + CS%coordinateResolution(k-1) * stretching + nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching z_col_new(k) = max( z_col_new(k), nominal_z ) z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) enddo diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index c7e8007d26..bee6832f77 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -38,7 +38,6 @@ module coord_rho integer, parameter :: NB_REGRIDDING_ITERATIONS = 1 !> Deviation tolerance between succesive grids in regridding iterations real, parameter :: DEVIATION_TOLERANCE = 1e-10 -! This CPP macro embeds some safety checks public init_coord_rho, set_rho_params, build_rho_column, old_inflate_layers_1d, end_coord_rho @@ -88,15 +87,23 @@ end subroutine set_rho_params !! !! 1. Density profiles are calculated on the source grid. !! 2. Positions of target densities (for interfaces) are found by interpolation. -subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface) - type(rho_CS), intent(in) :: CS !< coord_rho control structure - integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) - real, intent(in) :: depth !< Depth of ocean bottom (positive in m) - real, dimension(nz), intent(in) :: h !< Layer thicknesses, in m - real, dimension(nz), intent(in) :: T !< T for source column - real, dimension(nz), intent(in) :: S !< S for source column - type(EOS_type), pointer :: eqn_of_state !< Equation of state structure - real, dimension(CS%nk+1), intent(inout) :: z_interface !< Absolute positions of interfaces +subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & + h_neglect, h_neglect_edge) + type(rho_CS), intent(in) :: CS !< coord_rho control structure + integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) + real, intent(in) :: depth !< Depth of ocean bottom (positive in m) + real, dimension(nz), intent(in) :: h !< Layer thicknesses, in H + real, dimension(nz), intent(in) :: T !< T for source column + real, dimension(nz), intent(in) :: S !< S for source column + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + real, dimension(CS%nk+1), & + intent(inout) :: z_interface !< Absolute positions of interfaces + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. ! Local variables integer :: k, count_nonzero_layers integer, dimension(nz) :: mapping @@ -123,7 +130,8 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface) ! Based on source column density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & - h_nv, xTmp, CS%target_density, CS%nk, h_new, x1) + h_nv, xTmp, CS%target_density, CS%nk, h_new, & + x1, h_neglect, h_neglect_edge) ! Inflate vanished layers call old_inflate_layers_1d(CS%min_thickness, CS%nk, h_new) @@ -160,8 +168,9 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface) end subroutine build_rho_column -subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, zInterface) - !< Iteratively uild a rho coordinate column +subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, & + zInterface, h_neglect, h_neglect_edge) + !< Iteratively build a rho coordinate column !! !! The algorithm operates as follows within each column: !! @@ -182,6 +191,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, dimension(nz), intent(in) :: T, S !< T and S for column type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h ! Local variables integer :: k, m @@ -230,7 +245,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ ! One regridding iteration ! Based on global density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & - hTmp, xTmp, CS%target_density, nz, h1, x1) + hTmp, xTmp, CS%target_density, nz, h1, x1, h_neglect, h_neglect_edge) call old_inflate_layers_1d( CS%min_thickness, nz, h1 ) x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; end do @@ -240,10 +255,10 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ h1(k) = x1(k+1) - x1(k) end do - call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp) + call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp, h_neglect, h_neglect_edge) S_tmp(:) = Tmp(:) - call remapping_core_h(remapCS, nz, h0, T, nz, h1, Tmp) + call remapping_core_h(remapCS, nz, h0, T, nz, h1, Tmp, h_neglect, h_neglect_edge) T_tmp(:) = Tmp(:) ! Compute the deviation between two successive grids diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index da8bde731d..93f5b9c393 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -150,7 +150,8 @@ end subroutine set_slight_params !> Build a SLight coordinate column subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, & - nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new) + nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & + h_neglect, h_neglect_edge) type(slight_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: H_to_Pa !< GV%H_to_Pa @@ -163,6 +164,12 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, real, dimension(nz), intent(in) :: p_col !< Layer quantities real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface in H units (m or kg m-2) real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h_col. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h_col. ! Local variables real, dimension(nz) :: rho_col ! Layer quantities @@ -214,7 +221,8 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, ! Find the locations of the target potential densities, flagging ! locations in apparently unstable regions as not reliable. call rho_interfaces_col(rho_col, h_col, z_col, CS%target_density, nz, & - z_col_new, CS, reliable, debug=.true.) + z_col_new, CS, reliable, debug=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Ensure that the interfaces are at least CS%min_thickness apart. if (CS%min_thickness > 0.0) then @@ -443,7 +451,7 @@ end subroutine build_slight_column !> Finds the new interface locations in a column of water that match the !! prescribed target densities. subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & - CS, reliable, debug) + CS, reliable, debug, h_neglect, h_neglect_edge) integer, intent(in) :: nz !< Number of layers real, dimension(nz), intent(in) :: rho_col !< Initial layer reference densities. real, dimension(nz), intent(in) :: h_col !< Initial layer thicknesses. @@ -453,7 +461,13 @@ subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & type(slight_CS), intent(in) :: CS !< Coordinate control structure logical, dimension(nz+1), intent(inout) :: reliable !< If true, the interface positions !! are well defined from a stable region. - logical, optional, intent(in) :: debug !< If present and true, do debugging checks. + logical, optional, intent(in) :: debug !< If present and true, do debugging checks. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h_col. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h_col. real, dimension(nz+1) :: ru_max_int ! The maximum and minimum densities in real, dimension(nz+1) :: ru_min_int ! an unstable region around an interface. @@ -500,7 +514,7 @@ subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & ! This sets up the piecewise polynomials based on the rho_col profile. call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h_col, ppoly_i_E, ppoly_i_S, & - ppoly_i_coefficients, ppoly_degree) + ppoly_i_coefficients, ppoly_degree, h_neglect, h_neglect_edge) ! Determine the density ranges of unstably stratified segments. ! Interfaces that start out in an unstably stratified segment can diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index c6b438a0ac..f8781aa937 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -23,15 +23,15 @@ module regrid_edge_slopes public edge_slopes_implicit_h3 public edge_slopes_implicit_h5 -real, parameter :: h_neglect = 1.E-30 +! Specifying a dimensional parameter value, as is done here, is a terrible idea. +real, parameter :: hNeglect_dflt = 1.E-30 contains !------------------------------------------------------------------------------ -! Compute ih4 edge slopes (implicit third order accurate) -!------------------------------------------------------------------------------ -subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) +!> Compute ih4 edge slopes (implicit third order accurate) +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) ! ----------------------------------------------------------------------------- ! Compute edge slopes based on third-order implicit estimates. Note that ! the estimates are fourth-order accurate on uniform grids @@ -59,10 +59,13 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell averages (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_slopes + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j ! loop indexes @@ -81,6 +84,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + real :: hNeglect3 ! hNeglect^3 in the same units as h^3. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect3 = hNeglect**3 ! Loop on cells (except last one) do i = 1,N-1 @@ -99,9 +107,9 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 ! Coefficients - alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + h_neglect ) - beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + h_neglect ) - a = -12.0 * h0h1 / ( d + h_neglect ) + alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) + beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) + a = -12.0 * h0h1 / ( d + hNeglect3 ) b = -a tri_l(i+1) = alpha @@ -178,9 +186,8 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ -! Compute ih5 edge values (implicit fifth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) +!> Compute ih5 edge values (implicit fifth order accurate) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) ! ----------------------------------------------------------------------------- ! Fifth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -215,10 +222,13 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell averages (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_slopes + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j, k ! loop indexes @@ -247,6 +257,9 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) do k = 2,N-2 @@ -277,11 +290,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - d2 = ( h1_2 - g_2 ) / ( h0 + h_neglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + h_neglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + h_neglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + h_neglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + h_neglect ) + d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) + d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) + d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) + d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) + d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) g = h2 + h3 g_2 = g * g @@ -290,11 +303,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + h_neglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + h_neglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + h_neglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + h_neglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + h_neglect ) + n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) + n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) + n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) + n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) + n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -390,11 +403,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) h0ph1_3 = h0ph1_2 * h0ph1 h0ph1_4 = h0ph1_2 * h0ph1_2 - d2 = ( h1_2 - g_2 ) / ( h0 + h_neglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + h_neglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + h_neglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + h_neglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + h_neglect ) + d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) + d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) + d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) + d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) + d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) g = h2 + h3 g_2 = g * g @@ -403,11 +416,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + h_neglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + h_neglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + h_neglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + h_neglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + h_neglect ) + n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) + n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) + n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) + n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) + n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -530,11 +543,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) h2ph3_3 = h2ph3_2 * h2ph3 h2ph3_4 = h2ph3_2 * h2ph3_2 - d2 = ( h1_2 - g_2 ) / ( h0 + h_neglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + h_neglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + h_neglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + h_neglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + h_neglect ) + d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) + d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) + d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) + d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) + d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) g = h2 + h3 g_2 = g * g @@ -543,11 +556,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + h_neglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + h_neglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + h_neglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + h_neglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + h_neglect ) + n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) + n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) + n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) + n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) + n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) ! Compute matrix entries Asys(1,1) = 0.0 diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index c3035e36d2..fafb873a6c 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -33,15 +33,19 @@ module regrid_edge_values ! extrapolation. The are needed only in the case where thicknesses vanish ! to a small enough values such that the eigenvalues of the matrix can not ! be separated. -real, parameter :: hNegligible = 1.e-10 ! A cut-off minimum thickness for sum(h) -real, parameter :: hMinFrac = 1.e-5 ! A minimum fraction for min(h)/(sum(h) +! Specifying a dimensional parameter value, as is done here, is a terrible idea. +real, parameter :: hNeglect_edge_dflt = 1.e-10 ! The default value for cut-off minimum + ! thickness for sum(h) in edge value inversions +real, parameter :: hNeglect_dflt = 1.e-30 ! The default value for cut-off minimum + ! thickness for sum(h) in other calculations +real, parameter :: hMinFrac = 1.e-5 ! A minimum fraction for min(h)/sum(h) contains !------------------------------------------------------------------------------ ! Bound edge values by neighboring cell averages !------------------------------------------------------------------------------ -subroutine bound_edge_values( N, h, u, edge_values ) +subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! ------------------------------------------------------------------------------ ! In this routine, we loop on all cells to bound their left and right ! edge values by the cell averages. That is, the left edge value must lie @@ -54,10 +58,13 @@ subroutine bound_edge_values( N, h, u, edge_values ) ! ------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! loop index @@ -69,6 +76,9 @@ subroutine bound_edge_values( N, h, u, edge_values ) ! van Leer slopes real :: slope ! retained PLM slope + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells to bound edge value do k = 1,N @@ -104,9 +114,9 @@ subroutine bound_edge_values( N, h, u, edge_values ) u0_l = edge_values(k,1) u0_r = edge_values(k,2) - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + 1.E-30 ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + 1.E-30 ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + 1.E-30 ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) if ( (sigma_l * sigma_r) .GT. 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -230,9 +240,8 @@ end subroutine check_discontinuous_edge_values !------------------------------------------------------------------------------ -! Compute h2 edge values (explicit second order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_explicit_h2( N, h, u, edge_values ) +!> Compute h2 edge values (explicit second order accurate) +subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) ! ------------------------------------------------------------------------------ ! Compute edge values based on second-order explicit estimates. ! These estimates are based on a straight line spanning two cells and evaluated @@ -247,15 +256,21 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values ) ! ------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! loop index real :: h0, h1 ! cell widths real :: u0, u1 ! cell averages + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on interior cells do k = 2,N @@ -265,8 +280,8 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values ) ! Avoid singularities when h0+h1=0 if (h0+h1==0.) then - h0 = hNegligible - h1 = hNegligible + h0 = hNeglect + h1 = hNeglect endif u0 = u(k-1) @@ -289,9 +304,8 @@ end subroutine edge_values_explicit_h2 !------------------------------------------------------------------------------ -! Compute h4 edge values (explicit fourth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_explicit_h4( N, h, u, edge_values ) +!> Compute h4 edge values (explicit fourth order accurate) +subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order explicit estimates. ! These estimates are based on a cubic interpolant spanning four cells @@ -312,10 +326,13 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j @@ -326,6 +343,9 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) real, dimension(5) :: x ! used to compute edge real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on interior cells do i = 3,N-1 @@ -337,7 +357,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) ! Avoid singularities when consecutive pairs of h vanish if (h0+h1==0. .or. h1+h2==0. .or. h2+h3==0.) then - f1 = max( hNegligible, h0+h1+h2+h3 ) + f1 = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*f1, h(i-2) ) h1 = max( hMinFrac*f1, h(i-1) ) h2 = max( hMinFrac*f1, h(i) ) @@ -383,7 +403,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) end do ! end loop on interior cells ! Determine first two edge values - f1 = max( hNegligible, hMinFrac*sum(h(1:4)) ) + f1 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(i-1)) @@ -421,7 +441,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) #endif ! Determine last two edge values - f1 = max( hNegligible, hMinFrac*sum(h(N-3:N)) ) + f1 = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(N-5+i)) @@ -469,9 +489,8 @@ end subroutine edge_values_explicit_h4 !------------------------------------------------------------------------------ -! Compute ih4 edge values (implicit fourth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_implicit_h4( N, h, u, edge_values ) +!> Compute ih4 edge values (implicit fourth order accurate) +subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order implicit estimates. ! @@ -497,10 +516,13 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j ! loop indexes @@ -517,6 +539,9 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) do i = 1,N-1 @@ -527,8 +552,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) ! Avoid singularities when h0+h1=0 if (h0+h1==0.) then - h0 = hNegligible - h1 = hNegligible + h0 = hNeglect + h1 = hNeglect endif ! Auxiliary calculations @@ -553,7 +578,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) end do ! end loop on cells ! Boundary conditions: left boundary - h0 = max( hNegligible, hMinFrac*sum(h(1:4)) ) + h0 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(i-1) ) @@ -576,7 +601,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! first edge value ! Boundary conditions: right boundary - h0 = max( hNegligible, hMinFrac*sum(h(N-3:N)) ) + h0 = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(N-5+i) ) @@ -612,9 +637,8 @@ end subroutine edge_values_implicit_h4 !------------------------------------------------------------------------------ -! Compute ih6 edge values (implicit sixth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_implicit_h6( N, h, u, edge_values ) +!> Compute ih6 edge values (implicit sixth order accurate) +subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) ! ----------------------------------------------------------------------------- ! Sixth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -649,10 +673,13 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j, k ! loop indexes @@ -681,6 +708,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) do k = 2,N-2 @@ -693,7 +723,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNegligible, h0+h1+h2+h3 ) + g = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*g, h0 ) h1 = max( hMinFrac*g, h1 ) h2 = max( hMinFrac*g, h2 ) @@ -810,7 +840,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNegligible, h0+h1+h2+h3 ) + g = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*g, h0 ) h1 = max( hMinFrac*g, h1 ) h2 = max( hMinFrac*g, h2 ) @@ -922,7 +952,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) tri_b(2) = a * u(1) + b * u(2) + c * u(3) + d * u(4) ! Boundary conditions: left boundary - g = max( hNegligible, hMinFrac*sum(h(1:6)) ) + g = max( hNeglect, hMinFrac*sum(h(1:6)) ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(i-1) ) @@ -955,7 +985,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNegligible, h0+h1+h2+h3 ) + g = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*g, h0 ) h1 = max( hMinFrac*g, h1 ) h2 = max( hMinFrac*g, h2 ) @@ -1067,7 +1097,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) ! Boundary conditions: right boundary - g = max( hNegligible, hMinFrac*sum(h(N-5:N)) ) + g = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(N-7+i) ) diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 8495b48791..6858e0cded 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -71,22 +71,28 @@ module regrid_interp !! a third-order PPM ih4 scheme). In these cases, we resort to the simplest !! continuous linear scheme (P1M h2). subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & - ppoly0_coefficients, degree) + ppoly0_coefs, degree, h_neglect, h_neglect_edge) type(interp_CS_type),intent(in) :: CS !< Interpolation control structure real, dimension(:), intent(in) :: densities !< Actual cell densities integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(:), intent(in) :: h0 !< cell widths on source grid - real, dimension(:,:),intent(inout) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:),intent(inout) :: ppoly0_S !< Edge slope of polynomial - real, dimension(:,:),intent(inout) :: ppoly0_coefficients !< Coefficients of polynomial - integer, intent(inout) :: degree !< The degree of the polynomials + real, dimension(:,:),intent(inout) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:),intent(inout) :: ppoly0_S !< Edge slope of polynomial + real, dimension(:,:),intent(inout) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(inout) :: degree !< The degree of the polynomials + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. logical :: extrapolate ! Reset piecewise polynomials ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 - ppoly0_coefficients(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 extrapolate = CS%boundary_extrapolation @@ -95,146 +101,156 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H2 ) degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) end if - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) end if - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if case ( INTERPOLATION_PLM ) degree = DEGREE_1 - call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) end if case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_3 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S ) - call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect ) + call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, h_neglect_edge ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_3 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S ) - call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect ) + call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, h_neglect_edge ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_4 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S ) - call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect ) + call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_4 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S ) - call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect ) + call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if end select @@ -245,18 +261,19 @@ end subroutine regridding_set_ppolys !! Given the grid 'grid0' and the piecewise polynomial interpolant !! 'ppoly0' (possibly discontinuous), the coordinates of the new grid 'grid1' !! are determined by finding the corresponding target interface densities. -subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefficients, target_values, degree, n1, h1, x1 ) +subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & + target_values, degree, n1, h1, x1 ) ! Arguments - integer, intent(in) :: n0 !< Number of points on source grid - real, dimension(:), intent(in) :: h0 !< Thicknesses of source grid cells - real, dimension(:), intent(in) :: x0 !< Source interface positions - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials - real, dimension(:,:), intent(in) :: ppoly0_coefficients !< Coefficients of interpolating polynomials - real, dimension(:), intent(in) :: target_values !< Target values of interfaces - integer, intent(in) :: degree !< Degree of interpolating polynomials - integer, intent(in) :: n1 !< Number of points on target grid - real, dimension(:), intent(inout) :: h1 !< Thicknesses of target grid cells - real, dimension(:), intent(inout) :: x1 !< Target interface positions + integer, intent(in) :: n0 !< Number of points on source grid + real, dimension(:), intent(in) :: h0 !< Thicknesses of source grid cells + real, dimension(:), intent(in) :: x0 !< Source interface positions + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of interpolating polynomials + real, dimension(:), intent(in) :: target_values !< Target values of interfaces + integer, intent(in) :: degree !< Degree of interpolating polynomials + integer, intent(in) :: n1 !< Number of points on target grid + real, dimension(:), intent(inout) :: h1 !< Thicknesses of target grid cells + real, dimension(:), intent(inout) :: x1 !< Target interface positions ! Local variables integer :: k ! loop index @@ -270,26 +287,37 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefficients, target_v ! Find coordinates for interior target values do k = 2,n1 t = target_values(k) - x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefficients, t, degree ) + x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree ) h1(k-1) = x1(k) - x1(k-1) end do h1(n1) = x1(n1+1) - x1(n1) end subroutine interpolate_grid -subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, n1, h1, x1) - type(interp_CS_type), intent(in) :: CS - real, dimension(:), intent(in) :: densities, target_values - integer, intent(in) :: n0, n1 - real, dimension(:), intent(in) :: h0, x0 - real, dimension(:), intent(inout) :: h1, x1 +subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, & + n1, h1, x1, h_neglect, h_neglect_edge) + type(interp_CS_type), intent(in) :: CS !< A control structure for regrid_interp + real, dimension(:), intent(in) :: densities !< Input cell densities, in kg m-3 + real, dimension(:), intent(in) :: target_values !< Target values of interfaces + integer, intent(in) :: n0 !< The number of points on the input grid + real, dimension(:), intent(in) :: h0 !< Initial cell widths + real, dimension(:), intent(in) :: x0 !< Source interface positions + integer, intent(in) :: n1 !< The number of points on the output grid + real, dimension(:), intent(inout) :: h1 !< Output cell widths + real, dimension(:), intent(inout) :: x1 !< Target interface positions + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. real, dimension(n0,2) :: ppoly0_E, ppoly0_S real, dimension(n0,DEGREE_MAX+1) :: ppoly0_C integer :: degree call regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, ppoly0_C, & - degree) + degree, h_neglect, h_neglect_edge) call interpolate_grid(n0, h0, x0, ppoly0_E, ppoly0_C, target_values, degree, & n1, h1, x1) end subroutine build_and_interpolate_grid @@ -310,16 +338,16 @@ end subroutine build_and_interpolate_grid !! !! It is assumed that the number of cells defining 'grid' and 'ppoly' are the !! same. -function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefficients, & +function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & target_value, degree ) result ( x_tgt ) ! Arguments - integer, intent(in) :: N !< Number of grid cells - real, dimension(:), intent(in) :: h !< Grid cell thicknesses - real, dimension(:), intent(in) :: x_g !< Grid interface locations - real, dimension(:,:), intent(in) :: ppoly_E !< Edge values of interpolating polynomials - real, dimension(:,:), intent(in) :: ppoly_coefficients !< Coefficients of interpolating polynomials - real, intent(in) :: target_value !< Target value to find position for - integer, intent(in) :: degree !< Degree of the interpolating polynomials + integer, intent(in) :: N !< Number of grid cells + real, dimension(:), intent(in) :: h !< Grid cell thicknesses + real, dimension(:), intent(in) :: x_g !< Grid interface locations + real, dimension(:,:), intent(in) :: ppoly_E !< Edge values of interpolating polynomials + real, dimension(:,:), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials + real, intent(in) :: target_value !< Target value to find position for + integer, intent(in) :: degree !< Degree of the interpolating polynomials real :: x_tgt !< The position of x_g at which target_value is found. @@ -398,7 +426,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefficients, & ! the found cell a(:) = 0.0 do i = 1,degree+1 - a(i) = ppoly_coefficients(k_found,i) + a(i) = ppoly_coefs(k_found,i) end do ! Guess value to start Newton-Raphson iterations (middle of cell) @@ -468,14 +496,14 @@ end function interpolation_scheme subroutine set_interp_scheme(CS, interp_scheme) type(interp_CS_type), intent(inout) :: CS - character(len=*), intent(in) :: interp_scheme + character(len=*), intent(in) :: interp_scheme CS%interpolation_scheme = interpolation_scheme(interp_scheme) end subroutine set_interp_scheme subroutine set_interp_extrap(CS, extrapolation) type(interp_CS_type), intent(inout) :: CS - logical, intent(in) :: extrapolation + logical, intent(in) :: extrapolation CS%boundary_extrapolation = extrapolation end subroutine set_interp_extrap From 3cefe94f9f0585bc9e1b7e7985f4c7221bc7ced7 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 18 Dec 2017 08:13:02 -0500 Subject: [PATCH 066/170] Remove some unnecessary lines of code --- src/tracer/MOM_neutral_diffusion.F90 | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 0383c34741..c5b37e1c66 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1512,12 +1512,6 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K dT_top = T_right_top - T_left_top dT_bottom = T_right_bottom - T_left_bottom endif - if (signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then - dT_ave = 0. - else - dT_ave = dT_ave - endif - dT_ave = dT_ave endif dT_ave = 0.5 * ( dT_top + dT_bottom ) dT_layer = T_right_layer - T_left_layer From 28441a3580bbd8826a3ed828445739c5b419a3d8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Dec 2017 13:57:40 -0500 Subject: [PATCH 067/170] +(*)Set h_neglect in code calling remapping Set values of h_neglect and h_neglect edge that are consistent with the internal representation of thickness in MOM6, and added these arguments to the underlying regridding code. Altered routines include ALE_regrid_accelerated, pressure_gradient_plm, pressure_gradient_ppm, remap_all_state_vars, ALE_remap_scalar, build_rho_grid, build_grid_HyCOM1, and build_grid_SLight. Also shortened some internal variable names. All answers are bitwise identical in the test cases. --- src/ALE/MOM_ALE.F90 | 168 +++++++++++++++++++++++-------------- src/ALE/MOM_regridding.F90 | 36 +++++++- 2 files changed, 138 insertions(+), 66 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 0e269123d8..84407140ec 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -748,6 +748,14 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h_orig, tv, n, h_new, u, v) ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface, dzIntTotal + real :: h_neglect, h_neglect_edge + + !### 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif nz = GV%ke @@ -779,8 +787,10 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h_orig, tv, n, h_new, u, v) ! we need to use remapping_core because there isn't a tracer registry set up in ! the state initialization routine do j = G%jsc,G%jec ; do i = G%isc,G%iec - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h_new(i,j,:), tv_local%S(i,j,:)) - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h_new(i,j,:), tv_local%T(i,j,:)) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h_new(i,j,:), & + tv_local%S(i,j,:), h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h_new(i,j,:), & + tv_local%T(i,j,:), h_neglect, h_neglect_edge) enddo ; enddo @@ -824,6 +834,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G), SZJ_(G)) :: work_2d real :: Idt, ppt2mks real, dimension(GV%ke) :: h2 + real :: h_neglect, h_neglect_edge logical :: show_call_tree show_call_tree = .false. @@ -837,6 +848,13 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, "be remapped") 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + nz = GV%ke ppt2mks = 0.001 @@ -854,12 +872,9 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, endif ! Remap tracer -!$OMP parallel default(none) shared(G,GV,h_old,h_new,dxInterface,CS_remapping,nz,Reg,u,v,ntr,show_call_tree, & -!$OMP dt,CS_ALE,work_conc,work_cont,work_2d,Idt,ppt2mks) & -!$OMP private(h1,h2,dx,u_column) if (ntr>0) then if (show_call_tree) call callTree_waypoint("remapping tracers (remap_all_state_vars)") -!$OMP do + !$OMP parallel do default(shared) private(h1,h2,u_column) do m=1,ntr ! For each tracer do j = G%jsc,G%jec @@ -870,7 +885,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Build the start and final grids h1(:) = h_old(i,j,:) h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Reg%Tr(m)%t(i,j,:), nz, h2, u_column) + call remapping_core_h(CS_remapping, nz, h1, Reg%Tr(m)%t(i,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) ! Intermediate steps for tendency of tracer concentration and tracer content. ! Note: do not merge the two if-tests, since do_tendency_diag(:) is not @@ -951,7 +967,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap u velocity component if ( present(u) ) then -!$OMP do + !$OMP parallel do default(shared) private(h1,h2,dx,u_column) do j = G%jsc,G%jec do I = G%iscB,G%iecB if (G%mask2dCu(I,j)>0.) then @@ -965,7 +981,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, else h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) endif - call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, u_column) + call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) u(I,j,:) = u_column(:) endif enddo @@ -976,7 +993,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap v velocity component if ( present(v) ) then -!$OMP do + !$OMP parallel do default(shared) private(h1,h2,dx,u_column) do J = G%jscB,G%jecB do i = G%isc,G%iec if (G%mask2dCv(i,j)>0.) then @@ -990,13 +1007,13 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, else h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) endif - call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, u_column) + call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) v(i,J,:) = u_column(:) endif enddo enddo endif -!$OMP end parallel if (show_call_tree) call callTree_waypoint("v remapped (remap_all_state_vars)") if (show_call_tree) call callTree_leave("remap_all_state_vars()") @@ -1024,6 +1041,7 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c ! Local variables integer :: i, j, k, n_points real :: dx(GV%ke+1) + real :: h_neglect, h_neglect_edge logical :: ignore_vanished_layers, use_remapping_core_w ignore_vanished_layers = .false. @@ -1032,32 +1050,35 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c if (present(old_remap)) use_remapping_core_w = old_remap n_points = nk_src -!$OMP parallel default(none) shared(CS,G,GV,h_src,s_src,h_dst,s_dst & -!$OMP ,ignore_vanished_layers, use_remapping_core_w, nk_src ) & -!$OMP firstprivate(n_points,dx) -!$OMP do - do j = G%jsc,G%jec - do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - if (ignore_vanished_layers) then - n_points = 0 - do k = 1, nk_src - if (h_src(i,j,k)>0.) n_points = n_points + 1 - enddo - s_dst(i,j,:) = 0. - endif - if (use_remapping_core_w) then - call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) - call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), GV%ke, dx, s_dst(i,j,:)) - else - call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), s_dst(i,j,:)) - endif - else + !### 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + + !$OMP parallel do default(shared) firstprivate(n_points,dx) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j) > 0.) then + if (ignore_vanished_layers) then + n_points = 0 + do k = 1, nk_src + if (h_src(i,j,k)>0.) n_points = n_points + 1 + enddo s_dst(i,j,:) = 0. endif - enddo - enddo -!$OMP end parallel + if (use_remapping_core_w) then + call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) + call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & + GV%ke, dx, s_dst(i,j,:), h_neglect, h_neglect_edge) + else + call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & + GV%ke, h_dst(i,j,:), s_dst(i,j,:), h_neglect, h_neglect_edge) + endif + else + s_dst(i,j,:) = 0. + endif + enddo ; enddo end subroutine ALE_remap_scalar @@ -1083,25 +1104,35 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) real :: hTmp(GV%ke) real :: tmp(GV%ke) real, dimension(CS%nk,2) :: ppoly_linear_E !Edge value of polynomial - real, dimension(CS%nk,CS%degree_linear+1) :: ppoly_linear_coefficients !Coefficients of polynomial + real, dimension(CS%nk,CS%degree_linear+1) :: ppoly_linear_coefs !Coefficients of polynomial + real :: h_neglect + + !### Replace this with GV%H_subroundoff + !### Omit the rescaling by H_to_m here. It should not be needed. + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 * GV%H_to_m + else + h_neglect = GV%kg_m2_to_H*1.0e-30 * GV%H_to_m + endif ! NOTE: the variables 'CS%grid_generic' and 'CS%ppoly_linear' are declared at ! the module level. ! Determine reconstruction within each column -!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b) & -!$OMP private(hTmp,ppoly_linear_E,ppoly_linear_coefficients,tmp) +!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b,h_neglect) & +!$OMP private(hTmp,ppoly_linear_E,ppoly_linear_coefs,tmp) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 ! Build current grid + !### Omit the rescaling by H_to_m here. It should not be needed. hTmp(:) = h(i,j,:)*GV%H_to_m tmp(:) = tv%S(i,j,:) ! Reconstruct salinity profile - ppoly_linear_E = 0.0 - ppoly_linear_coefficients = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + ppoly_linear_E(:,:) = 0.0 + ppoly_linear_coefs(:,:) = 0.0 + call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) do k = 1,GV%ke S_t(i,j,k) = ppoly_linear_E(k,1) @@ -1109,12 +1140,12 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) end do ! Reconstruct temperature profile - ppoly_linear_E = 0.0 - ppoly_linear_coefficients = 0.0 + ppoly_linear_E(:,:) = 0.0 + ppoly_linear_coefs(:,:) = 0.0 tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) do k = 1,GV%ke T_t(i,j,k) = ppoly_linear_E(k,1) @@ -1150,29 +1181,40 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) real, dimension(CS%nk,2) :: & ppoly_parab_E !Edge value of polynomial real, dimension(CS%nk,CS%degree_parab+1) :: & - ppoly_parab_coefficients !Coefficients of polynomial + ppoly_parab_coefs !Coefficients of polynomial + real :: h_neglect + !### Replace this with GV%H_subroundoff + !### Omit the rescaling by H_to_m here. It should not be needed. + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 * GV%H_to_m + else + h_neglect = GV%kg_m2_to_H*1.0e-30 * GV%H_to_m + endif ! NOTE: the variables 'CS%grid_generic' and 'CS%ppoly_parab' are declared at ! the module level. ! Determine reconstruction within each column -!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b) & -!$OMP private(hTmp,tmp,ppoly_parab_E,ppoly_parab_coefficients) +!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b,h_neglect) & +!$OMP private(hTmp,tmp,ppoly_parab_E,ppoly_parab_coefs) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 ! Build current grid + !### Omit the rescaling by H_to_m here. It should not be needed. hTmp(:) = h(i,j,:) * GV%H_to_m tmp(:) = tv%S(i,j,:) ! Reconstruct salinity profile - ppoly_parab_E = 0.0 - ppoly_parab_coefficients = 0.0 - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + ppoly_parab_E(:,:) = 0.0 + ppoly_parab_coefs(:,:) = 0.0 + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E, h_neglect=1.0e-10) !###*GV%m_to_H ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, & + ppoly_parab_coefs, h_neglect ) do k = 1,GV%ke S_t(i,j,k) = ppoly_parab_E(k,1) @@ -1180,13 +1222,15 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) end do ! Reconstruct temperature profile - ppoly_parab_E = 0.0 - ppoly_parab_coefficients = 0.0 + ppoly_parab_E(:,:) = 0.0 + ppoly_parab_coefs(:,:) = 0.0 tmp(:) = tv%T(i,j,:) - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E, h_neglect=1.0e-10) !###*GV%m_to_H ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, & + ppoly_parab_coefs, h_neglect ) do k = 1,GV%ke T_t(i,j,k) = ppoly_parab_E(k,1) @@ -1348,13 +1392,13 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h ) type(ALE_CS), intent(inout) :: CS !< module control structure type(ocean_grid_type), intent(in) :: G !< module grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness in H ! Local variables integer :: i, j, k do j = G%jsd,G%jed ; do i = G%isd,G%ied - h(i,j,:) = getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) + h(i,j,:) = GV%m_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) enddo; enddo end subroutine ALE_initThicknessToCoord diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index f9b563d4f0..e9f755746e 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1290,10 +1290,18 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) integer :: i, j, k real :: nominalDepth, totalThickness real, dimension(SZK_(GV)+1) :: zOld, zNew + real :: h_neglect, h_neglect_edge #ifdef __DO_SAFETY_CHECKS__ real :: dh #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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + nz = GV%ke if (.not.CS%target_density_set) call MOM_error(FATAL, "build_rho_grid: "//& @@ -1313,7 +1321,8 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) nominalDepth = G%bathyT(i,j)*GV%m_to_H call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew) + tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) if (CS%integrate_downward_for_e) then zOld(1) = 0. @@ -1397,6 +1406,14 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) real, dimension(SZK_(GV)) :: p_col ! Layer pressure in Pa integer :: i, j, k, nz real :: depth + real :: h_neglect, h_neglect_edge + + !### 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif nz = GV%ke @@ -1417,7 +1434,9 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) enddo call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, nz, depth, & - h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new) + h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, & + z_col, z_col_new, zScale=GV%m_to_H, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) @@ -1510,6 +1529,14 @@ subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) real, dimension(SZK_(GV)) :: p_col ! Layer pressure in Pa real :: depth integer :: i, j, k, nz + real :: h_neglect, h_neglect_edge + + !### 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif nz = GV%ke @@ -1529,8 +1556,9 @@ subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) enddo call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_Pa, GV%m_to_H, & - GV%H_subroundoff, nz, depth, & - h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new) + GV%H_subroundoff, nz, depth, h(i, j, :), & + tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) From 5450210a2d52cd7878f051cc0aa82f48abd837b7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Dec 2017 15:16:16 -0500 Subject: [PATCH 068/170] (*)Rescale h_neglect in neutral_diffusion Rescale the negligible thickness used in some of the neutral_diffusion routines, including adding a new optional argument for edge remapping, so that answers do not change with the value of H_TO_M. Also reformatted many of the unit test calls to avoid overly long lines. All answers are bitwise identical when H_TO_M=1, and no test cases answers change. --- src/tracer/MOM_neutral_diffusion.F90 | 197 ++++++++++++++++++--------- 1 file changed, 129 insertions(+), 68 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 05b6164108..e47049fe1e 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -361,6 +361,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta + real :: h_neglect, h_neglect_edge + + !### 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif ! If doing along isopycnal diffusion (as opposed to neutral diffusion, set the reference pressure) if (CS%ref_pres>=0.) ref_pres(:) = CS%ref_pres @@ -385,13 +393,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) ! Interpolate state to interface do i = G%isc-1, G%iec+1 if (CS%continuous_reconstruction) then - call interface_scalar(G%ke, h(i,j,:), T(i,j,:), CS%Tint(i,j,:), 2) - call interface_scalar(G%ke, h(i,j,:), S(i,j,:), CS%Sint(i,j,:), 2) + call interface_scalar(G%ke, h(i,j,:), T(i,j,:), CS%Tint(i,j,:), 2, h_neglect) + call interface_scalar(G%ke, h(i,j,:), S(i,j,:), CS%Sint(i,j,:), 2, h_neglect) else call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), T(i,j,:), CS%ppoly_coeffs_T(i,j,:,:), & - CS%T_i(i,j,:,:), ppoly_r_S, iMethod ) + CS%T_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), S(i,j,:), CS%ppoly_coeffs_S(i,j,:,:), & - CS%S_i(i,j,:,:), ppoly_r_S, iMethod ) + CS%S_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) endif enddo @@ -491,6 +499,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) real, dimension(G%ke) :: dTracer ! change in tracer concentration due to ndiffusion integer :: i, j, k, ks, nk real :: ppt2mks, Idt, convert + real :: h_neglect, h_neglect_edge + + !### Try replacing both of these with GV%H_subroundoff + h_neglect_edge = GV%m_to_H*1.0e-10 + h_neglect = GV%m_to_H*1.0e-30 nk = GV%ke @@ -522,7 +535,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) CS%uPoL(I,j,:), CS%uPoR(I,j,:), & CS%uKoL(I,j,:), CS%uKoR(I,j,:), & CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, CS%remap_CS) + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) endif enddo ; enddo @@ -534,7 +547,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) CS%vPoL(i,J,:), CS%vPoR(i,J,:), & CS%vKoL(i,J,:), CS%vKoR(i,J,:), & CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, CS%remap_CS) + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) endif enddo ; enddo @@ -629,13 +642,14 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) end subroutine neutral_diffusion !> Returns interface scalar, Si, for a column of layer values, S. -subroutine interface_scalar(nk, h, S, Si, i_method) +subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) integer, intent(in) :: nk !< Number of levels real, dimension(nk), intent(in) :: h !< Layer thickness (H units) real, dimension(nk), intent(in) :: S !< Layer scalar (conc, e.g. ppt) real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (conc, e.g. ppt) integer, intent(in) :: i_method !< =1 use average of PLM edges !! =2 use continuous PPM edge interpolation + real, intent(in) :: h_neglect !< A negligibly small thickness (H units) ! Local variables integer :: k, km2, kp1 real, dimension(nk) :: diff @@ -657,7 +671,7 @@ subroutine interface_scalar(nk, h, S, Si, i_method) ! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. km2 = max(1, k-2) kp1 = min(nk, k+1) - Si(k) = ppm_edge(h(km2), h(k-1), h(k), h(kp1), S(k-1), S(k), diff(k-1), diff(k)) + Si(k) = ppm_edge(h(km2), h(k-1), h(k), h(kp1), S(k-1), S(k), diff(k-1), diff(k), h_neglect) enddo endif Si(nk+1) = S(nk) + 0.5 * diff(nk) @@ -666,7 +680,7 @@ end subroutine interface_scalar !> Returns the PPM quasi-fourth order edge value at k+1/2 following !! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. -real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1) +real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) real, intent(in) :: hkm1 !< Width of cell k-1 real, intent(in) :: hk !< Width of cell k real, intent(in) :: hkp1 !< Width of cell k+1 @@ -675,10 +689,10 @@ real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1) real, intent(in) :: Akp1 !< Average scalar value of cell k+1 real, intent(in) :: Pk !< PLM slope for cell k real, intent(in) :: Pkp1 !< PLM slope for cell k+1 + real, intent(in) :: h_neglect !< A negligibly small thickness (H units) ! Local variables real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1, f1, f2, f3, f4 - real, parameter :: h_neglect = 1.e-30 R_hk_hkp1 = hk + hkp1 if (R_hk_hkp1 <= 0.) then @@ -1769,7 +1783,8 @@ subroutine calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, end subroutine calc_delta_rho !> Returns a single column of neutral diffusion fluxes of a tracer. -subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, hEff, Flx, continuous, remap_CS) +subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, & + hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge) integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions @@ -1786,7 +1801,13 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces (Pa) real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers (conc H) logical, intent(in) :: continuous !< True if using continuous reconstruction + real, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. type(remapping_CS), optional, intent(in) :: remap_CS + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. ! Local variables integer :: k_sublayer, klb, klt, krb, krt, k real :: T_right_top, T_right_bottom, T_right_layer @@ -1809,8 +1830,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K ! Setup reconstruction edge values if (continuous) then - call interface_scalar(nk, hl, Tl, Til, 2) - call interface_scalar(nk, hr, Tr, Tir, 2) + call interface_scalar(nk, hl, Tl, Til, 2, h_neglect) + call interface_scalar(nk, hr, Tr, Tir, 2, h_neglect) call ppm_left_right_edge_values(nk, Tl, Til, aL_l, aR_l) call ppm_left_right_edge_values(nk, Tr, Tir, aL_r, aR_r) else @@ -1819,8 +1840,10 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K Tid_l(:,:) = 0. Tid_r(:,:) = 0. - call build_reconstructions_1d( remap_CS, nk, hl, Tl, ppoly_r_coeffs_l, Tid_l, ppoly_r_S_l, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hr, Tr, ppoly_r_coeffs_r, Tid_r, ppoly_r_S_r, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hl, Tl, ppoly_r_coeffs_l, Tid_l, & + ppoly_r_S_l, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hr, Tr, ppoly_r_coeffs_r, Tid_r, & + ppoly_r_S_r, iMethod, h_neglect, h_neglect_edge ) endif do k_sublayer = 1, nsurf-1 @@ -1929,47 +1952,80 @@ logical function ndiff_unit_tests_continuous(verbose) real, dimension(2*nk+1) :: Flx ! Test flux integer :: k logical :: v + real :: h_neglect, h_neglect_edge + + h_neglect_edge = 1.0e-10 ; h_neglect = 1.0e-30 v = verbose ndiff_unit_tests_continuous = .false. ! Normally return false write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_continuous =' - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,1.,1., 0.,1.,2., 1., 'FV: Straight line on uniform grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,1.,0., 0.,4.,8., 7., 'FV: Vanished right cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,0.,1.,1., 0.,4.,8., 7., 'FV: Vanished left cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,2.,4., 0.,3.,9., 4., 'FV: Stretched grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,2.,0.,2., 0.,1.,2., 0., 'FV: Vanished middle cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,0.,1.,0., 0.,1.,2., 2., 'FV: Vanished on both sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,0.,0., 0.,1.,2., 0., 'FV: Two vanished cell sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,0.,0.,0., 0.,1.,2., 0., 'FV: All vanished cells') - - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,1.,1., 0.,1.,2., 1., 'LSQ: Straight line on uniform grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,1.,0., 0.,1.,2., 1., 'LSQ: Vanished right cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,0.,1.,1., 0.,1.,2., 1., 'LSQ: Vanished left cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,2.,4., 0.,3.,9., 2., 'LSQ: Stretched grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,0.,1., 0.,1.,2., 2., 'LSQ: Vanished middle cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,0.,1.,0., 0.,1.,2., 0., 'LSQ: Vanished on both sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,0.,0., 0.,1.,2., 0., 'LSQ: Two vanished cell sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,0.,0.,0., 0.,1.,2., 0., 'LSQ: All vanished cells') - - call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 1) - !ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(5, Tio, (/27.,21.,15.,9.,3./), 'Linear profile, interface temperatures') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v,5, Tio, (/24.,22.5,15.,7.5,6./), 'Linear profile, linear interface temperatures') - call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 2) - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v,5, Tio, (/24.,22.,15.,8.,6./), 'Linear profile, PPM interface temperatures') - - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., 1.0, 1.0, 0.5, 'Check mid-point') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 0.0, 0., 1.0, 1.0, 0.0, 'Check bottom') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 0.1, 0., 1.1, 1.0, 0.0, 'Check below') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., 0.0, 1.0, 1.0, 'Check top') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., -0.1, 1.0, 1.0, 'Check above') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., 3.0, 1.0, 0.25, 'Check 1/4') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-3.0, 0., 1.0, 1.0, 0.75, 'Check 3/4') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 1.0, 0., 1.0, 1.0, 0.0, 'Check dRho=0 below') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., -1.0, 1.0, 1.0, 'Check dRho=0 above') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 0.0, 0., 0.0, 1.0, 0.5, 'Check dRho=0 mid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-2.0, .5, 5.0, 0.5, 0.5, 'Check dP=0') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,1.,1., 0.,1.,2., 1., 'FV: Straight line on uniform grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,1.,0., 0.,4.,8., 7., 'FV: Vanished right cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,1.,1., 0.,4.,8., 7., 'FV: Vanished left cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,2.,4., 0.,3.,9., 4., 'FV: Stretched grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,2.,0.,2., 0.,1.,2., 0., 'FV: Vanished middle cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,1.,0., 0.,1.,2., 2., 'FV: Vanished on both sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,0.,0., 0.,1.,2., 0., 'FV: Two vanished cell sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,0.,0., 0.,1.,2., 0., 'FV: All vanished cells') + + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,1.,1., 0.,1.,2., 1., 'LSQ: Straight line on uniform grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,1.,0., 0.,1.,2., 1., 'LSQ: Vanished right cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,1.,1., 0.,1.,2., 1., 'LSQ: Vanished left cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,2.,4., 0.,3.,9., 2., 'LSQ: Stretched grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,0.,1., 0.,1.,2., 2., 'LSQ: Vanished middle cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,1.,0., 0.,1.,2., 0., 'LSQ: Vanished on both sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,0.,0., 0.,1.,2., 0., 'LSQ: Two vanished cell sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,0.,0., 0.,1.,2., 0., 'LSQ: All vanished cells') + + call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 1, h_neglect) + !ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + ! test_data1d(5, Tio, (/27.,21.,15.,9.,3./), 'Linear profile, interface temperatures') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_data1d(v,5, Tio, (/24.,22.5,15.,7.5,6./), 'Linear profile, linear interface temperatures') + call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 2, h_neglect) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_data1d(v,5, Tio, (/24.,22.,15.,8.,6./), 'Linear profile, PPM interface temperatures') + + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 1.0, 1.0, 0.5, 'Check mid-point') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.0, 0., 1.0, 1.0, 0.0, 'Check bottom') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.1, 0., 1.1, 1.0, 0.0, 'Check below') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 0.0, 1.0, 1.0, 'Check top') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., -0.1, 1.0, 1.0, 'Check above') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 3.0, 1.0, 0.25, 'Check 1/4') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-3.0, 0., 1.0, 1.0, 0.75, 'Check 3/4') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 1.0, 0., 1.0, 1.0, 0.0, 'Check dRho=0 below') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., -1.0, 1.0, 1.0, 'Check dRho=0 above') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.0, 0., 0.0, 1.0, 0.5, 'Check dRho=0 mid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-2.0, .5, 5.0, 0.5, 0.5, 'Check dP=0') ! Identical columns call find_neutral_surface_positions_continuous(3, & @@ -1993,12 +2049,14 @@ logical function ndiff_unit_tests_continuous(verbose) (/0.,0.,10.,10.,20.,20.,30.,30./), '... right positions') call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR (/20.,16.,12./), (/20.,16.,12./), & ! Tl, Tr - PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true.) + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., & + h_neglect, h_neglect_edge=h_neglect_edge) ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & (/0.,0.,0.,0.,0.,0.,0./), 'Identical columns, rho flux (=0)') call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR (/-1.,-1.,-1./), (/1.,1.,1./), & ! Sl, Sr - PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true.) + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., & + h_neglect, h_neglect_edge=h_neglect_edge) ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & (/0.,20.,0.,20.,0.,20.,0./), 'Identical columns, S flux') @@ -2163,6 +2221,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) real, dimension(nk,2) :: poly_T_l, poly_T_r, poly_S, poly_slope ! Linear reconstruction for T real, dimension(nk,2) :: dRdT, dRdS integer :: iMethod + real :: h_neglect, h_neglect_edge integer :: k logical :: v @@ -2171,6 +2230,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) ndiff_unit_tests_discontinuous = .false. ! Normally return false write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' + h_neglect = 1.0e-30 ; h_neglect_edge = 1.0e-10 + ! Unit tests for find_neutral_surface_positions_discontinuous ! Salinity is 0 for all these tests Sl(:) = 0. ; Sr(:) = 0. ; poly_S(:,:) = 0. ; SiL(:,:) = 0. ; SiR(:,:) = 0. @@ -2182,8 +2243,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) do k = 1,nk ; Pres_l(k+1) = Pres_l(k) + hL(k) ; Pres_r(k+1) = Pres_r(k) + hR(k) ; enddo ! Identical columns Tl = (/20.,16.,12./) ; Tr = (/20.,16.,12./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2194,8 +2255,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns') Tl = (/20.,16.,12./) ; Tr = (/18.,14.,10./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2206,8 +2267,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column slightly cooler') Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) ; - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2218,8 +2279,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Left column slightly cooler') Tl = (/20.,16.,12./) ; Tr = (/14.,10.,6./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2230,8 +2291,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column somewhat cooler') Tl = (/20.,16.,12./) ; Tr = (/8.,6.,4./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2242,8 +2303,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column much cooler') Tl = (/14.,14.,10./) ; Tr = (/14.,14.,10./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2254,8 +2315,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns with mixed layer') Tl = (/20.,16.,12./) ; Tr = (/14.,14.,10./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2266,8 +2327,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column with mixed layer') Tl = (/14.,14.,6./) ; Tr = (/12.,16.,8./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & From 9974b02c254949abc389cb5e0fcb394e18cad0b8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Dec 2017 18:23:21 -0500 Subject: [PATCH 069/170] (*)Initialize thicknesses directly to H units Perform the conversion of thicknesses into the internal H unit representation inside of all of the intialization routines, allowing things like ALE remapping to work correctly during initialization. This affects a large number of routines for initializing thickness, temperatures and salinities, and velocities. With these changes (and changes to ALE), all MOM6 test cases now give the same initial values regardless of the scaling of H. All answers in the existing test cases are bitwise identical. --- .../MOM_state_initialization.F90 | 98 +++++++------ src/user/DOME2d_initialization.F90 | 41 +++--- src/user/DOME_initialization.F90 | 6 +- src/user/ISOMIP_initialization.F90 | 34 ++--- src/user/Neverland_initialization.F90 | 6 +- src/user/Phillips_initialization.F90 | 6 +- src/user/Rossby_front_2d_initialization.F90 | 52 +++---- src/user/SCM_CVmix_tests.F90 | 8 +- src/user/SCM_idealized_hurricane.F90 | 5 +- src/user/adjustment_initialization.F90 | 129 +++++++++--------- src/user/baroclinic_zone_initialization.F90 | 12 +- src/user/benchmark_initialization.F90 | 6 +- src/user/circle_obcs_initialization.F90 | 18 +-- src/user/external_gwave_initialization.F90 | 12 +- src/user/lock_exchange_initialization.F90 | 4 +- src/user/seamount_initialization.F90 | 16 +-- src/user/sloshing_initialization.F90 | 9 +- src/user/soliton_initialization.F90 | 11 +- src/user/user_initialization.F90 | 19 ++- 19 files changed, 256 insertions(+), 236 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 56e49a3fc9..09e0881607 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -164,6 +164,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & type(EOS_type), pointer :: eos => NULL() logical :: debug ! If true, write debugging output. logical :: debug_obc ! If true, do debugging calls related to OBCs. + logical :: debug_layers = .false. + character(len=80) :: mesg ! This include declares and sets the variable "version". #include "version_variable.h" integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -284,7 +286,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & just_read_params=just_read) case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, & PF, just_read_params=just_read) - case ("external_gwave"); call external_gwave_initialize_thickness(h, G, & + case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, & PF, just_read_params=just_read) case ("DOME2D"); call DOME2d_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) @@ -294,12 +296,12 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & just_read_params=just_read) case ("seamount"); call seamount_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) - case ("soliton"); call soliton_initialize_thickness(h, G) + case ("soliton"); call soliton_initialize_thickness(h, G, GV) case ("phillips"); call Phillips_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, & PF, just_read_params=just_read) - case ("USER"); call user_initialize_thickness(h, G, PF, tv%T, & + case ("USER"); call user_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized layer thickness configuration "//trim(config)) @@ -341,19 +343,19 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, PF, & just_read_params=just_read) case ("DOME2D"); call DOME2d_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("ISOMIP"); call ISOMIP_initialize_temperature_salinity ( tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("adjustment2d"); call adjustment_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("baroclinic_zone"); call baroclinic_zone_init_temperature_salinity( tv%T, & - tv%S, h, G, PF, just_read_params=just_read) + tv%S, h, G, GV, PF, just_read_params=just_read) case ("sloshing"); call sloshing_initialize_temperature_salinity(tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("seamount"); call seamount_initialize_temperature_salinity(tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("SCM_ideal_hurr"); call SCM_idealized_hurricane_TS_init ( tv%T, & tv%S, h, G, GV, PF, just_read_params=just_read) case ("SCM_CVmix_tests"); call SCM_CVmix_tests_TS_init (tv%T, & @@ -418,22 +420,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "units of m to kg m-2 or vice versa, depending on whether \n"//& "BOUSSINESQ is defined. This does not apply if a restart \n"//& "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) - if (new_sim) then - if (GV%Boussinesq .or. convert) then - ! Convert h from m to thickness units (H) - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k)*GV%m_to_H - enddo ; enddo ; enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k)*GV%kg_m2_to_H - enddo ; enddo ; enddo - endif - if (convert .and. .not.GV%Boussinesq) & - ! Convert thicknesses from geomtric distances to mass-per-unit-area. - call convert_thickness(h, G, GV, tv) - endif + if (new_sim .and. convert .and. .not.GV%Boussinesq) & + ! Convert thicknesses from geomtric distances to mass-per-unit-area. + call convert_thickness(h, G, GV, tv) ! Remove the mass that would be displaced by an ice shelf or inverse barometer. call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & @@ -489,6 +479,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_m) if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1) if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1) + if ( use_temperature .and. debug_layers) then ; do k=1,nz + write(mesg,'("MOM_IS: T[",I2,"]")') k + call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1) + write(mesg,'("MOM_IS: S[",I2,"]")') k + call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1) + enddo ; endif + endif call get_param(PF, mdl, "SPONGE", use_sponge, & @@ -607,8 +604,6 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne ! This subroutine reads the layer thicknesses from file. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) integer :: inconsistent = 0 - real :: dilate ! The amount by which each layer is dilated to agree - ! with the bottom depth and free surface height, nondim. logical :: correct_thickness logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. @@ -635,8 +630,12 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne " initialize_thickness_from_file: Unable to open "//trim(filename)) if (file_has_thickness) then + !### Consider adding a parameter to use to rescale h. if (just_read) return ! All run-time parameters have been read, so return. call MOM_read_data(filename, "h", h(:,:,:), G%Domain) + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%m_to_H * h(i,j,k) + enddo ; enddo ; enddo else call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & "If true, all mass below the bottom removed if the \n"//& @@ -652,9 +651,9 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_z)) then eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta(i,j,K) - eta(i,j,K+1) + h(i,j,k) = GV%m_to_H * (eta(i,j,K) - eta(i,j,K+1)) endif enddo ; enddo ; enddo @@ -690,8 +689,8 @@ end subroutine initialize_thickness_from_file subroutine adjustEtaToFitBathymetry(G, GV, eta, h) 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(SZI_(G),SZJ_(G), SZK_(G)+1), intent(inout) :: eta - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Layer thicknesses, in m + real, dimension(SZI_(G),SZJ_(G), SZK_(G)+1), intent(inout) :: eta !< Interface heights, in m + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations real, parameter :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria (m) @@ -714,6 +713,8 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) endif + ! To preserve previous answers, delay converting thicknesses to units of H + ! until the end of this routine. do k=nz,1,-1 ; do j=js,je ; do i=is,ie ! Collapse layers to thinnest possible if the thickness less than ! the thinnest possible (or negative). @@ -721,7 +722,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z h(i,j,k) = GV%Angstrom_z else - h(i,j,k) = eta(i,j,K) - eta(i,j,K+1) + h(i,j,k) = (eta(i,j,K) - eta(i,j,K+1)) endif enddo ; enddo ; enddo @@ -738,9 +739,15 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) dilate = (eta(i,j,1)+G%bathyT(i,j)) / (eta(i,j,1)-eta(i,j,nz+1)) do k=1,nz ; h(i,j,k) = h(i,j,k) * dilate ; enddo endif - do k=nz, 2, -1; eta(i,j,K) = eta(i,j,K+1) + h(i,j,k); enddo + do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + h(i,j,k) ; enddo endif enddo ; enddo + + ! Now convert thicknesses to units of H. + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = h(i,j,k)*GV%m_to_H + enddo ; enddo ; enddo + call sum_across_PEs(dilations) if ((dilations > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions were dilated ",'// & @@ -756,7 +763,7 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -803,9 +810,9 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo @@ -819,7 +826,7 @@ subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -889,9 +896,9 @@ subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo @@ -1959,7 +1966,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) ! type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: h !< Layer thicknesses being initialized, in m + intent(out) :: h !< Layer thicknesses being initialized, in H type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic !! variables including temperature and salinity type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -2016,7 +2023,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) real, dimension(:), allocatable :: z_edges_in, z_in, Rb real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z real, dimension(:,:,:), allocatable :: rho_z - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights in m. real, dimension(SZI_(G),SZJ_(G)) :: nlevs real, dimension(SZI_(G)) :: press @@ -2025,7 +2032,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) real, dimension(:), allocatable :: hTarget real, dimension(:,:), allocatable :: area_shelf_h real, dimension(:,:), allocatable, target :: frac_shelf_h - real, dimension(:,:,:), allocatable :: tmpT1dIn, tmpS1dIn, h1, tmp_mask_in + real, dimension(:,:,:), allocatable :: tmpT1dIn, tmpS1dIn, tmp_mask_in + real, dimension(:,:,:), allocatable :: h1 ! Thicknesses in H. real :: zTopOfCell, zBottomOfCell type(regridding_CS) :: regridCS ! Regridding parameters and work arrays type(remapping_CS) :: remapCS ! Remapping parameters and work arrays @@ -2229,11 +2237,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) tmpT1dIn(i,j,k) = -99.9 tmpS1dIn(i,j,k) = -99.9 endif - h1(i,j,k) = zTopOfCell - zBottomOfCell + h1(i,j,k) = GV%m_to_H * (zTopOfCell - zBottomOfCell) if (h1(i,j,k)>0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - h1(i,j,kd) = h1(i,j,kd) + ( zTopOfCell + G%bathyT(i,j) ) ! In case data is deeper than model + h1(i,j,kd) = h1(i,j,kd) + GV%m_to_H * ( zTopOfCell + G%bathyT(i,j) ) ! In case data is deeper than model endif ! mask2dT enddo ; enddo deallocate( tmp_mask_in ) @@ -2256,7 +2264,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) zTopOfCell = 0. ; zBottomOfCell = 0. do k = 1, nz zBottomOfCell = max( zTopOfCell - hTarget(k), -G%bathyT(i,j) ) - h(i,j,k) = zTopOfCell - zBottomOfCell + h(i,j,k) = GV%m_to_H * (zTopOfCell - zBottomOfCell) zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo else @@ -2315,9 +2323,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_z)) then zi(i,j,K) = zi(i,j,K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = zi(i,j,K) - zi(i,j,K+1) + h(i,j,k) = GV%m_to_H * (zi(i,j,K) - zi(i,j,K+1)) endif enddo ; enddo ; enddo inconsistent=0 diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 2456b2dbc8..108c468c5c 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -90,7 +90,7 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -150,17 +150,17 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - if ( x <= dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom_Z - h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z - endif + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + h(i,j,1:nz-1) = GV%Angstrom + h(i,j,nz) = GV%m_to_H * dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom + endif enddo ; enddo @@ -172,16 +172,16 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params ! eta1D(k) = e0(k) ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then ! eta1D(k) = eta1D(k+1) + min_thickness - ! h(i,j,k) = min_thickness + ! h(i,j,k) = GV%m_to_H * min_thickness ! else - ! h(i,j,k) = eta1D(k) - eta1D(k+1) + ! h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) ! endif ! enddo ! ! x = G%geoLonT(i,j) / G%len_lon ! if ( x <= dome2d_width_bay ) then - ! h(i,j,1:nz-1) = min_thickness - ! h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness + ! h(i,j,1:nz-1) = GV%m_to_H * min_thickness + ! h(i,j,nz) = GV%m_to_H * (dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness) ! endif ! ! enddo ; enddo @@ -194,9 +194,9 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness + h(i,j,k) = GV%m_to_H * min_thickness else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -204,7 +204,7 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params case ( REGRIDDING_SIGMA ) do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / nz - h(i,j,:) = delta_h + h(i,j,:) = GV%m_to_H * delta_h enddo ; enddo case default @@ -217,16 +217,17 @@ end subroutine DOME2d_initialize_thickness !> Initialize temperature and salinity in the 2d DOME configuration -subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & +subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in units of H (m or kg m-2) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. ! Local variables integer :: i, j, k, is, ie, js, je, nz @@ -275,7 +276,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth + xi1 = xi0 + (GV%H_to_m * h(i,j,k)) / G%max_depth S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo @@ -286,7 +287,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth + xi1 = xi0 + (GV%H_to_m * h(i,j,k)) / G%max_depth S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 35287e14f2..99c5f3de5c 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -77,7 +77,7 @@ subroutine DOME_initialize_thickness(h, G, GV, param_file, just_read_params) 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -115,9 +115,9 @@ subroutine DOME_initialize_thickness(h, G, GV, param_file, just_read_params) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index f91808bd59..639c4839ce 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -138,7 +138,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any @@ -211,9 +211,9 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -226,9 +226,9 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness + h(i,j,k) = GV%m_to_H * min_thickness else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -237,7 +237,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) - h(i,j,:) = delta_h + h(i,j,:) = GV%m_to_H * delta_h end do ; end do case default @@ -255,11 +255,11 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or kg m-2) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. ! Local variables integer :: i, j, k, is, ie, js, je, nz, itt @@ -309,12 +309,12 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, S_range = S_range / G%max_depth ! Convert S_range into dS/dz T_range = T_range / G%max_depth ! Convert T_range into dT/dz do j=js,je ; do i=is,ie - xi0 = -G%bathyT(i,j); + xi0 = -G%bathyT(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m ! Depth in middle of layer S(i,j,k) = S_sur + S_range * xi0 T(i,j,k) = T_sur + T_range * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) ! Depth at top of layer + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m ! Depth at top of layer enddo enddo ; enddo @@ -346,13 +346,13 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, T_range = T_range / G%max_depth ! Convert T_range into dT/dz do j=js,je ; do i=is,ie - xi0 = 0.0; + xi0 = 0.0 do k = 1,nz !T0(k) = T_Ref; S0(k) = S_Ref - xi1 = xi0 + 0.5 * h(i,j,k); - S0(k) = S_sur + S_range * xi1; - T0(k) = T_sur + T_range * xi1; - xi0 = xi0 + h(i,j,k); + xi1 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m + S0(k) = S_sur + S_range * xi1 + T0(k) = T_sur + T_range * xi1 + xi0 = xi0 + h(i,j,k) * GV%H_to_m !write(*,*)'S,T,xi0,xi1,k',S0(k),T0(k),xi0,xi1,k enddo @@ -584,7 +584,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) S_range = S_range / G%max_depth ! Convert S_range into dS/dz T_range = T_range / G%max_depth ! Convert T_range into dT/dz do j=js,je ; do i=is,ie - xi0 = -G%bathyT(i,j); + xi0 = -G%bathyT(i,j) do k = nz,1,-1 xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer S(i,j,k) = S_sur + S_range * xi0 diff --git a/src/user/Neverland_initialization.F90 b/src/user/Neverland_initialization.F90 index ed4ee5081c..d22d7457ab 100644 --- a/src/user/Neverland_initialization.F90 +++ b/src/user/Neverland_initialization.F90 @@ -110,7 +110,7 @@ subroutine Neverland_initialize_thickness(h, G, GV, param_file, eqn_of_state, P_ 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, intent(out), dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h !< The thickness that is being - !! initialized. + !! initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open !! file to parse for model !! parameter values. @@ -141,8 +141,8 @@ subroutine Neverland_initialize_thickness(h, G, GV, param_file, eqn_of_state, P_ do j=js,je ; do i=is,ie e_interface = -G%bathyT(i,j) do k=nz,1,-1 - h(i,j,k) = max( GV%Angstrom_z, e0(k) - e_interface ) - e_interface = max( e0(k), e_interface - h(i,j,k) ) + h(i,j,k) = max( GV%Angstrom, GV%m_to_H * (e0(k) - e_interface) ) + e_interface = max( e0(k), e_interface - GV%H_to_m * h(i,j,k) ) enddo enddo ; enddo diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index c6a9e160f6..163b85e1b5 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -35,7 +35,7 @@ subroutine Phillips_initialize_thickness(h, G, GV, param_file, just_read_params) 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -102,9 +102,9 @@ subroutine Phillips_initialize_thickness(h, G, GV, param_file, just_read_params) eta1D(K) = eta_im(j,K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 43bca2f117..0c63daaea8 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -42,7 +42,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -84,7 +84,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz - h(i,j,k) = h0 + h(i,j,k) = h0 * GV%m_to_H enddo end do ; end do @@ -95,7 +95,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz - h(i,j,k) = h0 + h(i,j,k) = h0 * GV%m_to_H enddo end do ; end do @@ -109,16 +109,17 @@ end subroutine Rossby_front_initialize_thickness !> Initialization of temperature and salinity in the Rossby front test -subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, & +subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & param_file, eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [deg C] real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness in H type(param_file_type), intent(in) :: param_file !< Parameter file handle type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz real :: T_ref, S_ref ! Reference salinity and temerature within surface layer @@ -151,7 +152,7 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, & zi = 0. do k = 1, nz zi = zi - h(i,j,k) ! Bottom interface position - zc = zi - 0.5*h(i,j,k) ! Position of middle of cell + zc = GV%H_to_m * (zi - 0.5*h(i,j,k)) ! Position of middle of cell zc = min( zc, -Hml(G, G%geoLatT(i,j)) ) ! Bound by depth of mixed layer T(i,j,k) = T_ref + dTdz * zc ! Linear temperature profile enddo @@ -162,21 +163,26 @@ end subroutine Rossby_front_initialize_temperature_salinity !> Initialization of u and v in the Rossby front test subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H] - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. - - real :: y ! Non-dimensional coordinate across channel, 0..pi - real :: T_range ! Range of salinities and temperatures over the vertical - real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f - real :: dRho_dT, zi, zc, zm, f, Ty, Dml, hAtU + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< i-component of velocity [m/s] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< j-component of velocity [m/s] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + intent(in) :: h !< Thickness [H] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, optional, intent(in) :: just_read_params !< If present and true, this call + !! will only read parameters without setting u & v. + + real :: y ! Non-dimensional coordinate across channel, 0..pi + real :: T_range ! Range of salinities and temperatures over the vertical + real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f + real :: dRho_dT + real :: Dml, zi, zc, zm ! Depths in units of m. + real :: f, Ty + real :: hAtU ! Interpolated layer thickness in units of m. integer :: i, j, k, is, ie, js, je, nz logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: verticalCoordinate @@ -204,7 +210,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file, just_rea Ty = dTdy( G, T_range, G%geoLatT(i,j) ) zi = 0. do k = 1, nz - hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) + hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) * GV%H_to_m zi = zi - hAtU ! Bottom interface position zc = zi - 0.5*hAtU ! Position of middle of cell zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer diff --git a/src/user/SCM_CVmix_tests.F90 b/src/user/SCM_CVmix_tests.F90 index be7f56ade2..74437a688f 100644 --- a/src/user/SCM_CVmix_tests.F90 +++ b/src/user/SCM_CVmix_tests.F90 @@ -102,17 +102,17 @@ subroutine SCM_CVmix_tests_TS_init(T, S, h, G, GV, param_file, just_read_params) do k=1,nz eta(K+1) = eta(K) - h(i,j,k)*GV%H_to_m ! Interface below layer (in m) zC = 0.5*( eta(K) + eta(K+1) ) ! Z of middle of layer (in m) - DZ = min(0., zC+UpperLayerTempMLD*GV%H_to_m) + DZ = min(0., zC + UpperLayerTempMLD) if (DZ.ge.0.0) then ! in Layer 1 T(i,j,k) = UpperLayerTemp else ! in Layer 2 - T(i,j,k) = LowerLayerTemp + LowerLayerdTdZ/GV%H_to_m * DZ + T(i,j,k) = LowerLayerTemp + LowerLayerdTdZ * DZ endif - DZ = min(0., zC+UpperLayerSaltMLD) + DZ = min(0., zC + UpperLayerSaltMLD) if (DZ.ge.0.0) then ! in Layer 1 S(i,j,k) = UpperLayerSalt else ! in Layer 2 - S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ/GV%H_to_m * DZ + S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ * DZ endif enddo ! k enddo ; enddo diff --git a/src/user/SCM_idealized_hurricane.F90 b/src/user/SCM_idealized_hurricane.F90 index e3ef6ad272..85b76c4ac5 100644 --- a/src/user/SCM_idealized_hurricane.F90 +++ b/src/user/SCM_idealized_hurricane.F90 @@ -50,7 +50,7 @@ subroutine SCM_idealized_hurricane_TS_init(T, S, h, G, GV, param_file, just_read type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (psu) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or Pa) type(param_file_type), intent(in) :: param_file !< Input parameter structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. @@ -86,8 +86,7 @@ subroutine SCM_idealized_hurricane_TS_init(T, S, h, G, GV, param_file, just_read do k=1,nz eta(K+1) = eta(K) - h(i,j,k)*GV%H_to_m ! Interface below layer (in m) zC = 0.5*( eta(K) + eta(K+1) ) ! Z of middle of layer (in m) - T(i,j,k) = SST_ref + dTdz/GV%H_to_m & - * min(0., zC+MLD*GV%H_to_m) + T(i,j,k) = SST_ref + dTdz * min(0., zC + MLD) S(i,j,k) = S_ref enddo ! k enddo ; enddo diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 795f85062d..0be1095d99 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -42,7 +42,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -131,40 +131,40 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par end do target_values = target_values - 1000. do j=js,je ; do i=is,ie - if (front_wave_length.ne.0.) then - y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) - yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width - yy = min(1.0, yy); yy = max(-1.0, yy) - yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + if (front_wave_length.ne.0.) then + y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) + yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width + yy = min(1.0, yy); yy = max(-1.0, yy) + yy = yy * 2. * acos( 0. ) + y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + else + y = 0. + endif + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width + x = min(1.0, x); x = max(-1.0, x) + x = x * acos( 0. ) + delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) + do k=2,nz + if (dSdz.ne.0.) then + eta1D(k) = ( target_values(k) - ( S_ref + delta_S ) ) / dSdz else - y = 0. + eta1D(k) = e0(k) - (0.5*adjustment_delta) * sin( x ) endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width - x = min(1.0, x); x = max(-1.0, x) - x = x * acos( 0. ) - delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) - do k=2,nz - if (dSdz.ne.0.) then - eta1D(k) = ( target_values(k) - ( S_ref + delta_S ) ) / dSdz - else - eta1D(k) = e0(k) - (0.5*adjustment_delta) * sin( x ) - endif - eta1D(k) = max( eta1D(k), -G%max_depth ) - eta1D(k) = min( eta1D(k), 0. ) - enddo - eta1D(1)=0.; eta1D(nz+1)=-G%max_depth - do k=nz,1,-1 - if (eta1D(k) > 0.) then - eta1D(k) = max( eta1D(k+1) + min_thickness, 0. ) - h(i,j,k) = max( eta1D(k) - eta1D(k+1), min_thickness ) - elseif (eta1D(k) <= (eta1D(k+1) + min_thickness)) then - eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness - else - h(i,j,k) = eta1D(k) - eta1D(k+1) - endif - enddo + eta1D(k) = max( eta1D(k), -G%max_depth ) + eta1D(k) = min( eta1D(k), 0. ) + enddo + eta1D(1)=0.; eta1D(nz+1)=-G%max_depth + do k=nz,1,-1 + if (eta1D(k) > 0.) then + eta1D(k) = max( eta1D(k+1) + min_thickness, 0. ) + h(i,j,k) = GV%m_to_H * max( eta1D(k) - eta1D(k+1), min_thickness ) + elseif (eta1D(k) <= (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = GV%m_to_H * min_thickness + else + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) + endif + enddo enddo ; enddo case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) @@ -174,13 +174,13 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par enddo do j=js,je ; do i=is,ie do k=nz,1,-1 - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) enddo enddo ; enddo case default call MOM_error(FATAL,"adjustment_initialize_thickness: "// & - "Unrecognized i.c. setup - set ADJUSTMENT_IC") + "Unrecognized i.c. setup - set ADJUSTMENT_IC") end select @@ -190,17 +190,18 @@ end subroutine adjustment_initialize_thickness !------------------------------------------------------------------------------ !> Initialization of temperature and salinity. !------------------------------------------------------------------------------ -subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, param_file, & +subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & eqn_of_state, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + 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(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The temperature that is being initialized. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thickness. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thicknesses in H (m or kg m-2). type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model parameter values. type(EOS_type), pointer :: eqn_of_state !< Equation of state. logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz real :: x, y, yy @@ -256,31 +257,31 @@ subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, param_file, case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) dSdz = -delta_S_strat/G%max_depth do j=js,je ; do i=is,ie - eta1d(nz+1)=-G%bathyT(i,j) - do k=nz,1,-1 - eta1d(k)=eta1d(k+1)+h(i,j,k) - enddo - if (front_wave_length.ne.0.) then - y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) - yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length - yy = min(1.0, yy); yy = max(-1.0, yy) - yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) - else - y = 0. - endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width - x = min(1.0, x); x = max(-1.0, x) - x = x * acos( 0. ) - delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) - do k=1,nz - S(i,j,k) = S_ref + delta_S + 0.5 * ( eta1D(k)+eta1D(k+1) ) * dSdz - x = abs(S(i,j,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) - x = 1.-min(1., x) - T(i,j,k) = x - enddo - ! x=sum(T(i,j,:)*h(i,j,:)) - ! T(i,j,:)=T(i,j,:)/x*(G%max_depth*1.5/real(nz)) + eta1d(nz+1) = -G%bathyT(i,j) + do k=nz,1,-1 + eta1d(k) = eta1d(k+1) + h(i,j,k)*GV%H_to_m + enddo + if (front_wave_length.ne.0.) then + y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) + yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length + yy = min(1.0, yy); yy = max(-1.0, yy) + yy = yy * 2. * acos( 0. ) + y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + else + y = 0. + endif + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width + x = min(1.0, x); x = max(-1.0, x) + x = x * acos( 0. ) + delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) + do k=1,nz + S(i,j,k) = S_ref + delta_S + 0.5 * ( eta1D(k)+eta1D(k+1) ) * dSdz + x = abs(S(i,j,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) + x = 1. - min(1., x) + T(i,j,k) = x + enddo + ! x=sum(T(i,j,:)*h(i,j,:)) + ! T(i,j,:)=T(i,j,:)/x*(G%max_depth*1.5/real(nz)) enddo ; enddo case ( REGRIDDING_LAYER, REGRIDDING_RHO ) diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index d90d9a4650..df51702416 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -6,6 +6,7 @@ module baroclinic_zone_initialization 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_verticalGrid, only : verticalGrid_type implicit none ; private @@ -65,15 +66,16 @@ subroutine bcz_params(G, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, dTdz, & end subroutine bcz_params !> Initialization of temperature and salinity with the baroclinic zone initial conditions -subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, param_file, & +subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, GV, param_file, & just_read_params) type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [deg C] real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thicknesses in H (m or kg m-2) type(param_file_type), intent(in) :: param_file !< Parameter file handle logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz real :: T_ref, dTdz, dTdx, delta_T ! Parameters describing temperature distribution @@ -108,8 +110,8 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, param_file, & fn = xs endif do k = nz, 1, -1 - zc = zi + 0.5*h(i,j,k) ! Position of middle of cell - zi = zi + h(i,j,k) ! Top interface position + zc = zi + 0.5*h(i,j,k)*GV%H_to_m ! Position of middle of cell + zi = zi + h(i,j,k)*GV%H_to_m ! Top interface position T(i,j,k) = T_ref + dTdz * zc & ! Linear temperature stratification + dTdx * x & ! Linear gradient + delta_T * fn ! Smooth fn of width L_zone diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 77072d10f9..7a1d3dc86b 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -79,7 +79,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, param_file, eqn_of_state, & 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(EOS_type), pointer :: eqn_of_state !< integer that selects the @@ -186,9 +186,9 @@ subroutine benchmark_initialize_thickness(h, G, GV, param_file, eqn_of_state, & if (eta1D(K) < eta1D(K+1) + GV%Angstrom_z) & eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = max(eta1D(K) - eta1D(K+1), GV%Angstrom_z) + h(i,j,k) = max(GV%m_to_H * (eta1D(K) - eta1D(K+1)), GV%Angstrom) enddo - h(i,j,1) = max(0.0 - eta1D(2), GV%Angstrom_z) + h(i,j,1) = max(GV%m_to_H * (0.0 - eta1D(2)), GV%Angstrom) enddo ; enddo diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 68f7d13535..ca89b812a6 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -25,7 +25,7 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para 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(SZI_(G),SZJ_(G), SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -69,15 +69,15 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo ! Perturb base state by circular anomaly in center - k=Nz + k=nz latC = G%south_lat + 0.5*G%len_lat lonC = G%west_lon + 0.5*G%len_lon do j=js,je ; do i=is,ie @@ -85,14 +85,14 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para ! if (rad <= 6.*diskrad) h(i,j,k) = h(i,j,k)+10.0*exp( -0.5*( rad**2 ) ) rad = min( rad, 1. ) ! Flatten outside radius of diskrad rad = rad*(2.*asin(1.)) ! Map 0-1 to 0-pi - if (Nz==1) then + if (nz==1) then ! The model is barotropic - h(i,j,k) = h(i,j,k) + 1.0*0.5*(1.+cos(rad)) ! cosine bell + h(i,j,k) = h(i,j,k) + GV%m_to_H * 1.0*0.5*(1.+cos(rad)) ! cosine bell else ! The model is baroclinic - do k = 1, Nz - h(i,j,k) = h(i,j,k) - 0.5*(1.+cos(rad)) & ! cosine bell - * 5.0 * real( 2*k-Nz ) + do k = 1, nz + h(i,j,k) = h(i,j,k) - GV%m_to_H * 0.5*(1.+cos(rad)) & ! cosine bell + * 5.0 * real( 2*k-nz ) enddo endif enddo ; enddo diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index daf00d46f5..e54d3e488e 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -8,6 +8,7 @@ module external_gwave_initialization use MOM_grid, only : ocean_grid_type use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private #include @@ -18,10 +19,11 @@ module external_gwave_initialization ! ----------------------------------------------------------------------------- !> This subroutine initializes layer thicknesses for the external_gwave experiment. -subroutine external_gwave_initialize_thickness(h, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: h !< The thickness that is being initialized, in m. +subroutine external_gwave_initialize_thickness(h, G, GV, param_file, just_read_params) + 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(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -70,7 +72,7 @@ subroutine external_gwave_initialize_thickness(h, G, param_file, just_read_param enddo eta1D(nz+1) = -G%max_depth ! Force bottom interface to bottom do k=1,nz - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) enddo enddo ; enddo diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index 72835f6d2d..e897db7c7a 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -24,7 +24,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, param_file, just_read_pa 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -83,7 +83,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, param_file, just_read_pa eta1D(K) = min( eta1D(K), eta1D(K-1) - GV%Angstrom_Z ) enddo do k=nz,1,-1 - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) enddo enddo ; enddo diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index c432d9fd30..46fb3d5a40 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -84,7 +84,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -153,9 +153,9 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -168,9 +168,9 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness + h(i,j,k) = GV%m_to_H * min_thickness else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -179,7 +179,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) - h(i,j,:) = delta_h + h(i,j,:) = GV%m_to_H * delta_h end do ; end do end select @@ -193,7 +193,7 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or Pa) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -257,7 +257,7 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth + xi1 = xi0 + GV%H_to_m * h(i,j,k) / G%max_depth select case ( trim(density_profile) ) case ('linear') !S(i,j,k) = S_surf + S_range * 0.5 * (xi0 + xi1) diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 6a72c7bd9f..a8221f945c 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -69,7 +69,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -169,7 +169,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param ! 4. Define layers total_height = 0.0 do k = 1,nz - h(i,j,k) = z_inter(k) - z_inter(k+1) + h(i,j,k) = GV%m_to_H * (z_inter(k) - z_inter(k+1)) total_height = total_height + h(i,j,k) end do @@ -186,12 +186,13 @@ end subroutine sloshing_initialize_thickness !! reference surface layer salinity and temperature and a specified range. !! Note that the linear distribution is set up with respect to the layer !! number, not the physical position). -subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, param_file, & +subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC). real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt). - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa). + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or Pa). type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index af1b69060e..62b535defe 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -30,9 +30,11 @@ module soliton_initialization contains !> Initialization of thicknesses in Equatorial Rossby soliton test -subroutine soliton_initialize_thickness(h, G) - type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: h !< Thickness +subroutine soliton_initialize_thickness(h, G, GV) + 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(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized, in H. integer :: i, j, k, is, ie, js, je, nz real :: x, y, x0, y0 @@ -54,8 +56,7 @@ subroutine soliton_initialize_thickness(h, G) y = G%geoLatT(i,j)-y0 val3 = exp(-val1*x) val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) - h(i,j,k) = 0.25*val4*(6.0*y*y+3.0)* & - exp(-0.5*y*y) + h(i,j,k) = GV%m_to_H * (0.25*val4 * (6.0*y*y+3.0) * exp(-0.5*y*y)) enddo end do ; end do diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 130594edf1..5e394089af 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -72,16 +72,15 @@ subroutine USER_initialize_topography(D, G, param_file, max_depth) end subroutine USER_initialize_topography !> initialize thicknesses. -subroutine USER_initialize_thickness(h, G, param_file, T, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, intent(out), dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h !< The thicknesses being - !! initialized. - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - real, intent(in), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: T !< Potential temperature. +subroutine USER_initialize_thickness(h, G, GV, param_file, just_read_params) + 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(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thicknesses being initialized, in H. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open + !! file to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing h. logical :: just_read ! If true, just read parameters but set nothing. @@ -93,7 +92,7 @@ subroutine USER_initialize_thickness(h, G, param_file, T, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. - h(:,:,1) = 0.0 + h(:,:,1) = 0.0 * GV%m_to_H if (first_call) call write_user_log(param_file) From ceb6f6f6416c909cbd3a0bd33c2d75aaaa62a797 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 19 Dec 2017 15:11:34 -0500 Subject: [PATCH 070/170] Updates for new dumbbell experiment --- .../solo_driver/MOM_surface_forcing.F90 | 8 +- src/core/MOM_open_boundary.F90 | 56 ++- .../MOM_fixed_initialization.F90 | 3 + .../MOM_state_initialization.F90 | 11 + src/user/dumbbell_initialization.F90 | 372 ++++++++++++++++++ src/user/dumbbell_surface_forcing.F90 | 349 ++++++++++++++++ 6 files changed, 783 insertions(+), 16 deletions(-) create mode 100644 src/user/dumbbell_initialization.F90 create mode 100644 src/user/dumbbell_surface_forcing.F90 diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 8f4fce6b88..846ad2a387 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -92,7 +92,8 @@ module MOM_surface_forcing use SCM_CVmix_tests, only : SCM_CVmix_tests_CS use BFB_surface_forcing, only : BFB_buoyancy_forcing use BFB_surface_forcing, only : BFB_surface_forcing_init, BFB_surface_forcing_CS - +use dumbbell_surface_forcing, only : dumbbell_surface_forcing_init, dumbbell_surface_forcing_CS +use dumbbell_surface_forcing, only : dumbbell_buoyancy_forcing use data_override_mod, only : data_override_init, data_override implicit none ; private @@ -202,6 +203,7 @@ module MOM_surface_forcing type(user_revise_forcing_CS), pointer :: urf_CS => NULL() type(user_surface_forcing_CS), pointer :: user_forcing_CSp => NULL() type(BFB_surface_forcing_CS), pointer :: BFB_forcing_CSp => NULL() + type(dumbbell_surface_forcing_CS), pointer :: dumbbell_forcing_CSp => NULL() type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() type(Neverland_surface_forcing_CS), pointer :: Neverland_forcing_CSp => NULL() type(SCM_idealized_hurricane_CS), pointer :: SCM_idealized_hurricane_CSp => NULL() @@ -328,6 +330,8 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%user_forcing_CSp) elseif (trim(CS%buoy_config) == "BFB") then call BFB_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%BFB_forcing_CSp) + elseif (trim(CS%buoy_config) == "dumbbell") then + call dumbbell_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%dumbbell_forcing_CSp) elseif (trim(CS%buoy_config) == "NONE") then call MOM_mesg("MOM_surface_forcing: buoyancy forcing has been set to omitted.") elseif (CS%variable_buoyforce .and. .not.CS%first_call_set_forcing) then @@ -1801,6 +1805,8 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) call USER_surface_forcing_init(Time, G, param_file, diag, CS%user_forcing_CSp) elseif (trim(CS%buoy_config) == "BFB" ) then call BFB_surface_forcing_init(Time, G, param_file, diag, CS%BFB_forcing_CSp) + elseif (trim(CS%buoy_config) == "dumbbell" ) then + call dumbbell_surface_forcing_init(Time, G, param_file, diag, CS%dumbbell_forcing_CSp) elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then call MESO_surface_forcing_init(Time, G, param_file, diag, CS%MESO_forcing_CSp) elseif (trim(CS%wind_config) == "Neverland") then diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 945fc5ad0e..d16eceae84 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1933,6 +1933,8 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) real, dimension(:,:), pointer :: seg_vel => NULL() ! pointer to segment velocity array real, dimension(:,:), pointer :: seg_trans => NULL() ! pointer to segment transport array real, dimension(:,:,:), allocatable :: tmp_buffer + logical :: brushcutter_mode + integer :: subsample_factor is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1941,6 +1943,13 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (.not. associated(OBC)) return + !will be able to dynamically switch between sub-sampling refined grid data or model grid + brushcutter_mode = .false. + if (brushcutter_mode) then + subsample_factor = 2 + else + subsample_factor = 1 + endif do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -1953,13 +1962,14 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) js_obc = max(segment%js_obc,jsd-1) je_obc = min(segment%je_obc,jed) - - if (segment%is_E_or_W) then - nj_seg=nj_seg-1 - js_obc=js_obc+1 - else - ni_seg=ni_seg-1 - is_obc=is_obc+1 + if (brushcutter_mode) then + if (segment%is_E_or_W) then + nj_seg=nj_seg-1 + js_obc=js_obc+1 + else + ni_seg=ni_seg-1 + is_obc=is_obc+1 + endif endif ! Calculate auxiliary fields at staggered locations. @@ -2026,23 +2036,39 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif ! read source data interpolated to the current model time if (siz(1)==1) then - allocate(tmp_buffer(1,nj_seg*2+1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + allocate(tmp_buffer(1,(nj_seg+1)*subsample_factor-1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid else - allocate(tmp_buffer(ni_seg*2+1,1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + allocate(tmp_buffer((ni_seg+1)*subsample_factor-1,1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid endif call time_interp_external(segment%field(m)%fid,Time, tmp_buffer) - if (siz(1)==1) then - segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) + if (brushcutter_mode) then + if (siz(1)==1) then + segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) + else + segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)-1:2*(ie_obc+G%idg_offset)-1:2,1,:) + endif else - segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)-1:2*(ie_obc+G%idg_offset)-1:2,1,:) + if (siz(1)==1) then + segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) + else + segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) + endif endif if (segment%field(m)%nk_src > 1) then call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer) - if (siz(1)==1) then - segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) + if (brushcutter_mode) then + if (siz(1)==1) then + segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) + else + segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)-1:2*(ie_obc+G%idg_offset)-1:2,1,:) + endif else - segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)-1:2*(ie_obc+G%idg_offset)-1:2,1,:) + if (siz(1)==1) then + segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) + else + segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) + endif endif do j=js_obc,je_obc do i=is_obc,ie_obc diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index f38f29ae46..7aff08540a 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -35,6 +35,7 @@ module MOM_fixed_initialization use Kelvin_initialization, only : Kelvin_initialize_topography use sloshing_initialization, only : sloshing_initialize_topography use seamount_initialization, only : seamount_initialize_topography +use dumbbell_initialization, only : dumbbell_initialize_topography use shelfwave_initialization, only : shelfwave_initialize_topography use supercritical_initialization, only : supercritical_initialize_topography use Phillips_initialization, only : Phillips_initialize_topography @@ -201,6 +202,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF) " \t\t DOME2D gravity current/overflow test case. \n"//& " \t Kelvin - flat but with rotated land mask.\n"//& " \t seamount - Gaussian bump for spontaneous motion test case.\n"//& + " \t dumbbell - Sloshing channel with reservoirs on both ends.\n"//& " \t shelfwave - exponential slope for shelfwave test case.\n"//& " \t supercritical - flat but with 8.95 degree land mask.\n"//& " \t Phillips - ACC-like idealized topography used in the Phillips config.\n"//& @@ -222,6 +224,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF) case ("Kelvin"); call Kelvin_initialize_topography(D, G, PF, max_depth) case ("sloshing"); call sloshing_initialize_topography(D, G, PF, max_depth) case ("seamount"); call seamount_initialize_topography(D, G, PF, max_depth) + case ("dumbbell"); call dumbbell_initialize_topography(D, G, PF, max_depth) case ("shelfwave"); call shelfwave_initialize_topography(D, G, PF, max_depth) case ("supercritical"); call supercritical_initialize_topography(D, G, PF, max_depth) case ("Phillips"); call Phillips_initialize_topography(D, G, PF, max_depth) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 9943a301e6..d28299e912 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -67,6 +67,8 @@ module MOM_state_initialization use sloshing_initialization, only : sloshing_initialize_temperature_salinity use seamount_initialization, only : seamount_initialize_thickness use seamount_initialization, only : seamount_initialize_temperature_salinity +use dumbbell_initialization, only : dumbbell_initialize_thickness +use dumbbell_initialization, only : dumbbell_initialize_temperature_salinity use Phillips_initialization, only : Phillips_initialize_thickness use Phillips_initialization, only : Phillips_initialize_velocity use Phillips_initialization, only : Phillips_initialize_sponges @@ -83,6 +85,7 @@ module MOM_state_initialization use BFB_initialization, only : BFB_initialize_sponges_southonly use dense_water_initialization, only : dense_water_initialize_TS use dense_water_initialization, only : dense_water_initialize_sponges +use dumbbell_initialization, only : dumbbell_initialize_sponges use midas_vertmap, only : find_interfaces, tracer_Z_init use midas_vertmap, only : determine_temperature @@ -254,6 +257,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t adjustment2d - TBD AJA. \n"//& " \t sloshing - TBD AJA. \n"//& " \t seamount - TBD AJA. \n"//& + " \t dumbbell - TBD AJA. \n"//& " \t soliton - Equatorial Rossby soliton. \n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t USER - call a user modified routine.", & @@ -295,6 +299,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & just_read_params=just_read) case ("seamount"); call seamount_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) + case ("dumbbell"); call dumbbell_initialize_thickness(h, G, GV, PF, & + just_read_params=just_read) case ("soliton"); call soliton_initialize_thickness(h, G) case ("phillips"); call Phillips_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) @@ -324,6 +330,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t adjustment2d - TBD AJA. \n"//& " \t sloshing - TBD AJA. \n"//& " \t seamount - TBD AJA. \n"//& + " \t dumbbell. \n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t SCM_ideal_hurr - used in the SCM idealized hurricane test.\n"//& " \t SCM_CVmix_tests - used in the SCM CVmix tests.\n"//& @@ -353,6 +360,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & tv%S, h, G, PF, eos, just_read_params=just_read) case ("seamount"); call seamount_initialize_temperature_salinity(tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) + case ("dumbbell"); call dumbbell_initialize_temperature_salinity(tv%T, & + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & tv%S, h, G, PF, eos, just_read_params=just_read) case ("SCM_ideal_hurr"); call SCM_idealized_hurricane_TS_init ( tv%T, & @@ -517,6 +526,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & PF, sponge_CSp, h) case ("BFB"); call BFB_initialize_sponges_southonly(G, use_temperature, tv, & PF, sponge_CSp, h) + case ("DUMBBELL"); call dumbbell_initialize_sponges(G, GV, tv, & + PF, useALE, sponge_CSp, ALE_sponge_CSp) case ("phillips"); call Phillips_initialize_sponges(G, use_temperature, tv, & PF, sponge_CSp, h) case ("dense"); call dense_water_initialize_sponges(G, GV, tv, PF, useALE, & diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 new file mode 100644 index 0000000000..db730b4dbb --- /dev/null +++ b/src/user/dumbbell_initialization.F90 @@ -0,0 +1,372 @@ +module dumbbell_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_domains, only : sum_across_PEs +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, fieldtype, file_exists +use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE +use MOM_io, only : write_field, slasher, vardesc +use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS +use MOM_tracer_registry, only : tracer_registry_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA +use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge + +implicit none ; private + +#include + +character(len=40) :: mdl = "dumbbell_initialization" ! This module's name. + +! ----------------------------------------------------------------------------- +! The following routines are visible to the outside world +! ----------------------------------------------------------------------------- +public dumbbell_initialize_topography +public dumbbell_initialize_thickness +public dumbbell_initialize_temperature_salinity +public dumbbell_initialize_sponges +! ----------------------------------------------------------------------------- +! This module contains the following routines +! ----------------------------------------------------------------------------- +contains + +!> Initialization of topography. +subroutine dumbbell_initialize_topography ( D, G, param_file, max_depth ) + ! Arguments + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in m + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum depth of model in m + + ! Local variables + integer :: i, j + real :: x, y, delta, dblen + + + call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & + 'Lateral Length scale for dumbbell ',& + units='k', default=600., do_not_log=.false.) + + if (G%x_axis_units == 'm') then + dblen=dblen*1.e3 + endif + + + do i=G%isc,G%iec + do j=G%jsc,G%jec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / dblen + y = ( G%geoLatT(i,j) ) / G%len_lat + D(i,j)=G%max_depth + if ((x>=-0.25 .and. x<=0.25) .and. (y<=-.25 .or. y>=0.25)) then + D(i,j) = 0.0 + endif + enddo + enddo + +end subroutine dumbbell_initialize_topography + +!> Initialization of thicknesses. +!! This subroutine initializes the layer thicknesses to be uniform. +subroutine dumbbell_initialize_thickness ( h, G, GV, param_file, just_read_params) + 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(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized, in m. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, optional, intent(in) :: just_read_params !< If present and true, this call will + !! only read parameters without changing h. + + real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! + ! negative because it is positive upward. ! + real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! + ! positive upward, in m. ! + integer :: i, j, k, is, ie, js, je, nz + real :: x + real :: delta_h + real :: min_thickness, S_surf, S_range, S_ref, S_light, S_dense + character(len=20) :: verticalCoordinate + logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + just_read = .false. ; if (present(just_read_params)) just_read = just_read_params + + if (.not.just_read) & + call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") + + call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & + 'Minimum thickness for layer',& + units='m', default=1.0e-3, do_not_log=just_read) + call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + + ! WARNING: this routine specifies the interface heights so that the last layer + ! is vanished, even at maximum depth. In order to have a uniform + ! layer distribution, use this line of code within the loop: + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + ! To obtain a thickness distribution where the last layer is + ! vanished and the other thicknesses uniformly distributed, use: + ! e0(k) = -G%max_depth * real(k-1) / real(nz-1) + !do k=1,nz+1 + ! e0(k) = -G%max_depth * real(k-1) / real(nz) + !enddo + + select case ( coordinateMode(verticalCoordinate) ) + + case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates + call get_param(param_file, mdl,"INITIAL_SSS", S_surf, default=34., do_not_log=.true.) + call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, default=2., do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) + if (just_read) return ! All run-time parameters have been read, so return. + + do K=1,nz+1 + ! Salinity of layer k is S_light + (k-1)/(nz-1) * (S_dense - S_light) + ! Salinity of interface K is S_light + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Salinity at depth z should be S(z) = S_surf - S_range * z/max_depth + ! Equating: S_surf - S_range * z/max_depth = S_light + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Equating: - S_range * z/max_depth = S_light - S_surf + (K-3/2)/(nz-1) * (S_dense - S_light) + ! Equating: z/max_depth = - ( S_light - S_surf + (K-3/2)/(nz-1) * (S_dense - S_light) ) / S_range + e0(K) = - G%max_depth * ( ( S_light - S_surf ) + ( S_dense - S_light ) * ( (real(K)-1.5) / real(nz-1) ) ) / S_range + e0(K) = nint(2048.*e0(K))/2048. ! Force round numbers ... the above expression has irrational factors ... + e0(K) = min(real(1-K)*GV%Angstrom_z, e0(K)) ! Bound by surface + e0(K) = max(-G%max_depth, e0(K)) ! Bound by bottom + enddo + do j=js,je ; do i=is,ie + eta1D(nz+1) = -1.0*G%bathyT(i,j) + do k=nz,1,-1 + eta1D(k) = e0(k) + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_z + h(i,j,k) = GV%Angstrom_z + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_ZSTAR ) ! Initial thicknesses for z coordinates + if (just_read) return ! All run-time parameters have been read, so return. + do j=js,je ; do i=is,ie + eta1D(nz+1) = -1.0*G%bathyT(i,j) + do k=nz,1,-1 + eta1D(k) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates + if (just_read) return ! All run-time parameters have been read, so return. + do j=js,je ; do i=is,ie + delta_h = G%bathyT(i,j) / dfloat(nz) + h(i,j,:) = delta_h + end do ; end do + +end select + +end subroutine dumbbell_initialize_thickness + +!> Initial values for temperature and salinity +subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & + eqn_of_state, just_read_params) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + logical, optional, intent(in) :: just_read_params !< If present and true, this call will + !! only read parameters without changing h. + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz, k_light + real :: xi0, xi1, dxi, r, S_surf, T_surf, S_range, T_range + real :: x, y, dblen + real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat + logical :: just_read ! If true, just read parameters but set nothing. + character(len=20) :: verticalCoordinate, density_profile + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + just_read = .false. ; if (present(just_read_params)) just_read = just_read_params + + T_surf = 20.0 + + 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,"INITIAL_DENSITY_PROFILE", density_profile, & + 'Initial profile shape. Valid values are "linear", "parabolic"\n'// & + 'and "exponential".', default='linear', do_not_log=just_read) + call get_param(param_file, mdl,"DUMBBELL_SREF", S_surf, & + 'DUMBBELL REFERENCE SALINITY', units='1e-3', default=34., do_not_log=just_read) + call get_param(param_file, mdl,"DUMBBELL_S_RANGE", S_range, & + 'DUMBBELL salinity range (right-left)', units='1e-3', & + default=2., do_not_log=just_read) + call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & + 'Lateral Length scale for dumbbell ',& + units='k', default=600., do_not_log=just_read) + + if (G%x_axis_units == 'm') then + dblen=dblen*1.e3 + endif + + + + do j=G%jsc,G%jec + do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / dblen + do k=1,nz + T(i,j,k)=T_surf + enddo + if (x>=0. ) then + do k=1,nz + S(i,j,k)=S_surf + 0.5*S_range + enddo + endif + if (x<0. ) then + do k=1,nz + S(i,j,k)=S_surf - 0.5*S_range + enddo + endif + + enddo + enddo + +end subroutine dumbbell_initialize_temperature_salinity + + +!> Initialize the restoring sponges for the dense water experiment +subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid control structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + type(param_file_type), intent(in) :: param_file !< Parameter file structure + logical, intent(in) :: use_ALE !< ALE flag + type(sponge_CS), pointer :: CSp !< Layered sponge control structure pointer + type(ALE_sponge_CS), pointer :: ACSp !< ALE sponge control structure pointer + + real :: sponge_time_scale + + real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, T, S ! sponge thicknesses, temp and salt + real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge + + integer :: i, j, k, nz + real :: x, zi, zmid, dist, min_thickness, dblen + real :: mld, S_ref, S_range, S_dense, T_ref, sill_height + call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & + 'Lateral Length scale for dumbbell ',& + units='k', default=600., do_not_log=.true.) + + if (G%x_axis_units == 'm') then + dblen=dblen*1.e3 + endif + + + nz = GV%ke + + call get_param(param_file, mdl, "DUMBBELL_SPONGE_TIME_SCALE", sponge_time_scale, & + "The time scale in the reservoir for restoring. If zero, the sponge is disabled.", & + units="s", default=0.) + call get_param(param_file, mdl, "DUMBBELL_SREF", S_ref, do_not_log=.true.) + call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, do_not_log=.true.) + call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & + 'Minimum thickness for layer',& + units='m', default=1.0e-3, do_not_log=.true.) + + + ! no active sponges + if (sponge_time_scale <= 0.) return + + ! everywhere is initially unsponged + Idamp(:,:) = 0.0 + + do j = G%jsc, G%jec + do i = G%isc,G%iec + if (G%mask2dT(i,j) > 0.) then + ! nondimensional x position + x = (G%geoLonT(i,j) ) / dblen + if (x > 0.25 .or. x < -0.25) then + ! scale restoring by depth into sponge + Idamp(i,j) = 1. / sponge_time_scale + endif + endif + enddo + enddo + + if (use_ALE) then + ! construct a uniform grid for the sponge + do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta1D(nz+1) = -1.0*G%bathyT(i,j) + do k=nz,1,-1 + eta1D(k) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(k) < (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = min_thickness + else + h(i,j,k) = eta1D(k) - eta1D(k+1) + endif + enddo + enddo ; enddo + + + call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) + + + ! construct temperature and salinity for the sponge + ! start with initial condition + S(:,:,:) = 0.0 + + do j=G%jsc,G%jec + do i=G%isc,G%iec + + + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / dblen + if (x>=0.25 ) then + do k=1,nz + S(i,j,k)=S_ref + 0.5*S_range + enddo + endif + if (x<=-0.25 ) then + do k=1,nz + S(i,j,k)=S_ref - 0.5*S_range + enddo + endif +! if (j.eq.G%jsc) print *,'i,Sponge S= ',i,S(i,1,1) + enddo + + + enddo + endif + + if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, tv%S, ACSp) + +end subroutine dumbbell_initialize_sponges + + +!> \namespace dumbbell_initialization +!! +!! The module configures the model for the idealized dumbbell +!! test case. +end module dumbbell_initialization diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 new file mode 100644 index 0000000000..f49202f919 --- /dev/null +++ b/src/user/dumbbell_surface_forcing.F90 @@ -0,0 +1,349 @@ +module dumbbell_surface_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* * +!* This file contains subroutines for specifying surface dynamic * +!* forcing for the dumbbell case. * +!* * +!********+*********+*********+*********+*********+*********+*********+** +use MOM_diag_mediator, only : post_data, query_averaging_enabled +use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, param_file_type, log_version +use MOM_forcing_type, only : forcing, allocate_forcing_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, read_data +use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_tracer_flow_control, only : call_tracer_set_forcing +use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_variables, only : surface + +implicit none ; private + +public dumbbell_dynamic_forcing, dumbbell_buoyancy_forcing, dumbbell_surface_forcing_init + +type, public :: dumbbell_surface_forcing_CS ; private + ! This control structure should be used to store any run-time variables + ! associated with the user-specified forcing. It can be readily modified + ! for a specific case, and because it is private there will be no changes + ! needed in other code (although they will have to be recompiled). + ! The variables in the cannonical example are used for some common + ! cases, but do not need to be used. + + logical :: use_temperature ! If true, temperature and salinity are used as + ! state variables. + logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. + real :: Rho0 ! The density used in the Boussinesq + ! approximation, in kg m-3. + real :: G_Earth ! The gravitational acceleration in m s-2. + real :: Flux_const ! The restoring rate at the surface, in m s-1. + real :: gust_const ! A constant unresolved background gustiness + ! that contributes to ustar, in Pa. + real :: slp_amplitude ! The amplitude of pressure loading (in Pa) applied + ! to the reservoirs + real :: slp_period ! Period of sinusoidal pressure wave + real :: S_surf, S_range + real, pointer, dimension(:,:) :: forcing_mask, S_restore + type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the + ! timing of diagnostic output. +end type dumbbell_surface_forcing_CS + +contains + +subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, CS) + type(surface), intent(inout) :: state + type(forcing), intent(inout) :: fluxes + type(time_type), intent(in) :: day + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply, in s + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(dumbbell_surface_forcing_CS), pointer :: CS + +! This subroutine specifies the current surface fluxes of buoyancy or +! temperature and fresh water. It may also be modified to add +! surface fluxes of user provided tracers. + +! When temperature is used, there are long list of fluxes that need to be +! set - essentially the same as for a full coupled model, but most of these +! can be simply set to zero. The net fresh water flux should probably be +! set in fluxes%evap and fluxes%lprec, with any salinity restoring +! appearing in fluxes%vprec, and the other water flux components +! (fprec, lrunoff and frunoff) left as arrays full of zeros. +! Evap is usually negative and precip is usually positive. All heat fluxes +! are in W m-2 and positive for heat going into the ocean. All fresh water +! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. + +! Arguments: state - A structure containing fields that describe the +! surface state of the ocean. +! (out) fluxes - A structure containing pointers to any possible +! forcing fields. Unused fields have NULL ptrs. +! (in) day_start - Start time of the fluxes. +! (in) day_interval - Length of time over which these fluxes +! will be applied. +! (in) G - The ocean's grid structure. +! (in) CS - A pointer to the control structure returned by a previous +! call to user_surface_forcing_init + + real :: Temp_restore ! The temperature that is being restored toward, in C. + real :: Salin_restore ! The salinity that is being restored toward, in PSU. + real :: density_restore ! The potential density that is being restored + ! toward, in kg m-3. + real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. + real :: buoy_rest_const ! A constant relating density anomalies to the + ! restoring buoyancy flux, in m5 s-3 kg-1. + integer :: i, j, is, ie, js, je + integer :: isd, ied, jsd, jed + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + ! When modifying the code, comment out this error message. It is here + ! so that the original (unmodified) version is not accidentally used. + ! call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & + ! "User forcing routine called without modification." ) + + ! Allocate and zero out the forcing arrays, as necessary. This portion is + ! usually not changed. + if (CS%use_temperature) then + call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) + + call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + else ! This is the buoyancy only mode. + call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + endif + + + ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. + + if ( CS%use_temperature ) then + ! Set whichever fluxes are to be used here. Any fluxes that + ! are always zero do not need to be changed here. + do j=js,je ; do i=is,ie + ! Fluxes of fresh water through the surface are in units of kg m-2 s-1 + ! and are positive downward - i.e. evaporation should be negative. + fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) + + ! vprec will be set later, if it is needed for salinity restoring. + fluxes%vprec(i,j) = 0.0 + + ! Heat fluxes are in units of W m-2 and are positive into the ocean. + fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) + enddo ; enddo + else ! This is the buoyancy only mode. + do j=js,je ; do i=is,ie + ! fluxes%buoy is the buoyancy flux into the ocean in m2 s-3. A positive + ! buoyancy flux is of the same sign as heating the ocean. + fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) + enddo ; enddo + endif + + if (CS%use_temperature .and. CS%restorebuoy) then + do j=js,je ; do i=is,ie + ! Set density_restore to an expression for the surface potential + ! density in kg m-3 that is being restored toward. + if (CS%forcing_mask(i,j)>0.) then + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + ((CS%S_restore(i,j) - state%SSS(i,j)) / & + (0.5 * (CS%S_restore(i,j) + state%SSS(i,j)))) + + end if + enddo ; enddo + endif + ! end RESTOREBUOY + +end subroutine dumbbell_buoyancy_forcing + +subroutine dumbbell_dynamic_forcing(state, fluxes, day, dt, G, CS) + type(surface), intent(inout) :: state + type(forcing), intent(inout) :: fluxes + type(time_type), intent(in) :: day + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply, in s + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(dumbbell_surface_forcing_CS), pointer :: CS + +! This subroutine specifies the current surface fluxes of buoyancy or +! temperature and fresh water. It may also be modified to add +! surface fluxes of user provided tracers. + +! When temperature is used, there are long list of fluxes that need to be +! set - essentially the same as for a full coupled model, but most of these +! can be simply set to zero. The net fresh water flux should probably be +! set in fluxes%evap and fluxes%lprec, with any salinity restoring +! appearing in fluxes%vprec, and the other water flux components +! (fprec, lrunoff and frunoff) left as arrays full of zeros. +! Evap is usually negative and precip is usually positive. All heat fluxes +! are in W m-2 and positive for heat going into the ocean. All fresh water +! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. + +! Arguments: state - A structure containing fields that describe the +! surface state of the ocean. +! (out) fluxes - A structure containing pointers to any possible +! forcing fields. Unused fields have NULL ptrs. +! (in) day_start - Start time of the fluxes. +! (in) day_interval - Length of time over which these fluxes +! will be applied. +! (in) G - The ocean's grid structure. +! (in) CS - A pointer to the control structure returned by a previous +! call to user_surface_forcing_init + + integer :: i, j, is, ie, js, je + integer :: isd, ied, jsd, jed + integer :: idays, isecs + real :: deg_rad, rdays + + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + deg_rad = atan(1.0)*4.0/180. + + call get_time(day,isecs,idays) + rdays = real(idays) + real(isecs)/8.64e4 + ! When modifying the code, comment out this error message. It is here + ! so that the original (unmodified) version is not accidentally used. + ! call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & + ! "User forcing routine called without modification." ) + + ! Allocate and zero out the forcing arrays, as necessary. This portion is + ! usually not changed. + call alloc_if_needed(fluxes%p_surf, isd, ied, jsd, jed) + call alloc_if_needed(fluxes%p_surf_full, isd, ied, jsd, jed) + + + ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. + + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = CS%forcing_mask(i,j)* CS%slp_amplitude * G%mask2dT(i,j) * sin(deg_rad*(rdays/CS%slp_period)) + fluxes%p_surf_full(i,j) = CS%forcing_mask(i,j) * CS%slp_amplitude * G%mask2dT(i,j) * sin(deg_rad*(rdays/CS%slp_period)) + enddo; enddo + + + +end subroutine dumbbell_dynamic_forcing + +subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) + ! If ptr is not associated, this routine allocates it with the given size + ! and zeros out its contents. This is equivalent to safe_alloc_ptr in + ! MOM_diag_mediator, but is here so as to be completely transparent. + real, pointer :: ptr(:,:) + integer :: isd, ied, jsd, jed + if (.not.ASSOCIATED(ptr)) then + allocate(ptr(isd:ied,jsd:jed)) + ptr(:,:) = 0.0 + endif +end subroutine alloc_if_needed + +subroutine dumbbell_surface_forcing_init(Time, G, param_file, diag, CS) + type(time_type), intent(in) :: Time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag + type(dumbbell_surface_forcing_CS), pointer :: CS +! Arguments: Time - The current model time. +! (in) G - The ocean's grid structure. +! (in) param_file - A structure indicating the open file to parse for +! model parameter values. +! (in) diag - A structure that is used to regulate diagnostic output. +! (in/out) CS - A pointer that is set to point to the control structure +! for this module + + ! This include declares and sets the variable "version". + + integer :: i,j + real :: x,y + +#include "version_variable.h" + character(len=40) :: mdl = "dumbbell_surface_forcing" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "dumbbell_surface_forcing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & + "If true, Temperature and salinity are used as state \n"//& + "variables.", default=.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) + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to \n"//& + "calculate accelerations and the mass for conservation \n"//& + "properties, or with BOUSSINSEQ false to convert some \n"//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0) + call get_param(param_file, mdl, "DUMBBELL_SLP_AMP", CS%slp_amplitude, & + "Amplitude of SLP forcing in reservoirs.", & + units="kg m2 s-1", default = 10000.0) + call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & + "Periodicity of SLP forcing in reservoirs.", & + units="days", default = 1.0) + call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & + "Periodicity of SLP forcing in reservoirs.", & + units="days", default = 1.0) + call get_param(param_file, mdl,"INITIAL_SSS", CS%S_surf, & + "Initial surface salinity", units="1e-3", default=34.0, do_not_log=.true.) + call get_param(param_file, mdl,"INITIAL_S_RANGE", CS%S_range, & + "Initial salinity range (bottom - surface)", units="1e-3", & + default=2., do_not_log=.true.) + + call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & + "If true, the buoyancy fluxes drive the model back \n"//& + "toward some specified surface state with a rate \n"//& + "given by FLUXCONST.", default= .false.) + if (CS%restorebuoy) then + call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + "The constant that relates the restoring surface fluxes \n"//& + "to the relative surface anomalies (akin to a piston \n"//& + "velocity). Note the non-MKS units.", units="m day-1", & + fail_if_missing=.true.) + ! Convert CS%Flux_const from m day-1 to m s-1. + CS%Flux_const = CS%Flux_const / 86400.0 + + + allocate(CS%forcing_mask(G%isd:G%ied, G%jsd:G%jed)); CS%forcing_mask(:,:)=0.0 + allocate(CS%S_restore(G%isd:G%ied, G%jsd:G%jed)) + + do j=G%jsc,G%jec + do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 + y = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 + CS%forcing_mask(i,j)=0 + CS%S_restore(i,j) = CS%S_surf + if ((x>0.25)) then + CS%forcing_mask(i,j) = 1 + CS%S_restore(i,j) = CS%S_surf + CS%S_range + else if ((x<-0.25)) then + CS%forcing_mask(i,j) = 1 + CS%S_restore(i,j) = CS%S_surf - CS%S_range + endif + enddo + enddo + endif +end subroutine dumbbell_surface_forcing_init + +end module dumbbell_surface_forcing From ceced366a43ed8b21d62756d34e917ab07208a8c Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 19 Dec 2017 17:21:23 -0500 Subject: [PATCH 071/170] Add appropriate limiters for discontinuous reconstruction --- src/tracer/MOM_neutral_diffusion.F90 | 123 +++++++++++++++++++-------- 1 file changed, 89 insertions(+), 34 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index c5b37e1c66..695fd9b19f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1432,9 +1432,9 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K type(remapping_CS), optional, intent(in) :: remap_CS ! Local variables integer :: k_sublayer, klb, klt, krb, krt, k - real :: T_right_top, T_right_bottom, T_right_layer - real :: T_left_top, T_left_bottom, T_left_layer - real :: dT_top, dT_bottom, dT_layer, dT_ave + real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int + real :: T_left_top, T_left_bottom, T_left_layer, T_left_sub, T_left_top_int, T_left_bot_int + real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int real, dimension(nk+1) :: Til !< Left-column interface tracer (conc, e.g. degC) real, dimension(nk+1) :: Tir !< Right-column interface tracer (conc, e.g. degC) real, dimension(nk) :: aL_l !< Left-column left edge value of tracer (conc, e.g. degC) @@ -1449,7 +1449,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, dimension(nk,deg+1) :: ppoly_r_coeffs_r real, dimension(nk,deg+1) :: ppoly_r_S_l real, dimension(nk,deg+1) :: ppoly_r_S_r - + logical :: down_flux ! Setup reconstruction edge values if (continuous) then call interface_scalar(nk, hl, Tl, Til, 2) @@ -1486,45 +1486,100 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K aL_r(krt), aR_r(krt), Tr(krt)) dT_top = T_right_top - T_left_top dT_bottom = T_right_bottom - T_left_bottom - else ! Discontinuous reconstruction - klb = KoL(k_sublayer+1) - klt = KoL(k_sublayer) - if (klt .ne. klb) then - call MOM_error(WARNING, "Neutral surfaces span more than one layer") - Flx(k_sublayer) = 0. - cycle + dT_ave = 0.5 * ( dT_top + dT_bottom ) + dT_layer = T_right_layer - T_left_layer + if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then + dT_ave = 0. + else + dT_ave = dT_layer endif - T_left_bottom = evaluation_polynomial( ppoly_r_coeffs_l(klb,:), deg+1, PiL(k_sublayer+1)) - T_left_top = evaluation_polynomial( ppoly_r_coeffs_l(klt,:), deg+1, PiL(k_sublayer)) - T_left_layer = average_value_ppoly(nk, Tl, Tid_l, ppoly_r_coeffs_l, iMethod, klb, & - PiL(k_sublayer), PiL(k_sublayer+1)) - krb = KoR(k_sublayer+1) - krt = KoR(k_sublayer) - if (krt .ne. krb) then - call MOM_error(WARNING, "Neutral surfaces span more than one layer") + Flx(k_sublayer) = dT_ave * hEff(k_sublayer) + else ! Discontinuous reconstruction + ! Calculate tracer values on left and right side of the neutral surface + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, ppoly_r_coeffs_l, & + T_left_top, T_left_bottom, T_left_sub, T_left_top_int, T_left_bot_int, T_left_layer) + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoR, PiR, Tr, Tid_r, deg, iMethod, ppoly_r_coeffs_r, & + T_right_top, T_right_bottom, T_right_sub, T_right_top_int, T_right_bot_int, T_right_layer) + + dT_top = T_right_top - T_left_top + dT_bottom = T_right_bottom - T_left_bottom + dT_sublayer = T_right_sub - T_left_sub + dT_top_int = T_right_top_int - T_left_top_int + dT_bot_int = T_right_bot_int - T_left_bot_int + ! Enforcing the below criterion incorrectly zero out fluxes + !dT_layer = T_right_layer - T_left_layer + + down_flux = dT_top <= 0. .and. dT_bottom <= 0. .and. & + dT_sublayer <= 0. .and. dT_top_int <= 0. .and. & + dT_bot_int <= 0. + down_flux = down_flux .or. & + (dT_top >= 0. .and. dT_bottom >= 0. .and. & + dT_sublayer >= 0. .and. dT_top_int >= 0. .and. & + dT_bot_int >= 0.) + if (down_flux) then + Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) + else Flx(k_sublayer) = 0. - cycle endif - T_right_bottom = evaluation_polynomial( ppoly_r_coeffs_r(krb,:), deg+1, PiR(k_sublayer+1)) - T_right_top = evaluation_polynomial( ppoly_r_coeffs_r(krt,:), deg+1, PiR(k_sublayer)) - T_right_layer = average_value_ppoly(nk, Tr, Tid_r, ppoly_r_coeffs_r, iMethod, krb, & - PiR(k_sublayer), PiR(k_sublayer+1)) - dT_top = T_right_top - T_left_top - dT_bottom = T_right_bottom - T_left_bottom endif endif - dT_ave = 0.5 * ( dT_top + dT_bottom ) - dT_layer = T_right_layer - T_left_layer - if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then - dT_ave = 0. - else - dT_ave = dT_layer - endif - Flx(k_sublayer) = dT_ave * hEff(k_sublayer) enddo end subroutine neutral_surface_flux +!> Evaluate various parts of the reconstructions to calculate gradient-based flux limter +subroutine neutral_surface_T_eval(nk, ns, k_sub, Ks, Ps, T_mean, T_int, deg, iMethod, T_poly, & + T_top, T_bot, T_sub, T_top_int, T_bot_int, T_layer) + integer, intent(in ) :: nk !< Number of cell everages + integer, intent(in ) :: ns !< Number of neutral surfaces + integer, intent(in ) :: k_sub !< Index of current neutral layer + integer, dimension(ns), intent(in ) :: Ks !< List of the layers associated with each neutral surface + real, dimension(ns), intent(in ) :: Ps !< List of the positions within a layer of each surface + real, dimension(nk), intent(in ) :: T_mean !< Cell average of tracer + real, dimension(nk,2), intent(in ) :: T_int !< Cell interface values of tracer from reconstruction + integer, intent(in ) :: deg !< Degree of reconstruction polynomial (e.g. 1 is linear) + integer, intent(in ) :: iMethod !< Method of integration to use + real, dimension(nk,deg+1), intent(in ) :: T_poly !< Coefficients of polynomial reconstructions + real, intent( out) :: T_top !< Tracer value at top (across discontinuity if necessary) + real, intent( out) :: T_bot !< Tracer value at bottom (across discontinuity if necessary) + real, intent( out) :: T_sub !< Average of the tracer value over the sublayer + real, intent( out) :: T_top_int !< Tracer value at top interface of neutral layer + real, intent( out) :: T_bot_int !< Tracer value at bottom interface of neutral layer + real, intent( out) :: T_layer !< Cell-average that the the reconstruction belongs to + + integer :: kl, ks_top, ks_bot + + ks_top = k_sub + ks_bot = k_sub + 1 + if ( Ks(ks_top) .ne. Ks(ks_bot) ) then + call MOM_error(FATAL, "Neutral surfaces span more than one layer") + endif + kl = Ks(k_sub) + ! First if the neutral surfaces spans the entirety of a cell, then do not search across the discontinuity + if ( (Ps(ks_top) == 0.) .and. (Ps(ks_bot) == 1.)) then + T_top = T_int(kl,1) + T_bot = T_int(kl,2) + else + ! Search across potential discontinuity at top + if ( (kl > 1) .and. (Ps(ks_top) == 0.) ) then + T_top = T_int(kl-1,2) + else + T_top = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_top) ) + endif + ! Search across potential discontinuity at bottom + if ( (kl < nk) .and. (Ps(ks_bot) == 1.) ) then + T_bot = T_int(kl+1,1) + else + T_bot = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_bot) ) + endif + endif + T_sub = average_value_ppoly(nk, T_mean, T_int, T_poly, iMethod, kl, Ps(ks_top), Ps(ks_bot)) + T_top_int = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_top)) + T_bot_int = evaluation_polynomial( T_poly(kl,:), deg+1, Ps(ks_bot)) + T_layer = T_mean(kl) + +end subroutine neutral_surface_T_eval + !> Discontinuous PPM reconstructions of the left/right edge values within a cell subroutine ppm_left_right_edge_values(nk, Tl, Ti, aL, aR) integer, intent(in) :: nk !< Number of levels From 8fe72facf9bf25f5e38c9804c1576731dab91d8f Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 20 Dec 2017 10:13:37 -0500 Subject: [PATCH 072/170] updates to make OBC data work with on-grid data instead of brushcutter --- config_src/solo_driver/MOM_driver.F90 | 5 ++ src/core/MOM_open_boundary.F90 | 108 +++++++++++++++++++++----- 2 files changed, 93 insertions(+), 20 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 5e727ed250..a18c2dd915 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -24,6 +24,8 @@ program MOM_main !* * !********+*********+*********+*********+*********+*********+*********+** + + use time_interp_external_mod, only : time_interp_external_init use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end @@ -206,6 +208,9 @@ program MOM_main deallocate(ocean_pelist) endif + !!! dont keep this here - move to mom open_boundary ### + call time_interp_external_init() + ! These clocks are on the global pelist. initClock = cpu_clock_id( 'Initialization' ) mainClock = cpu_clock_id( 'Main loop' ) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d16eceae84..a9c7bec4bf 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -431,6 +431,10 @@ subroutine initialize_segment_data(G, OBC, PF) integer, dimension(:), allocatable :: saved_pelist integer :: current_pe integer, dimension(1) :: single_pelist + !will be able to dynamically switch between sub-sampling refined grid data or model grid + logical :: brushcutter_mode + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -481,7 +485,8 @@ subroutine initialize_segment_data(G, OBC, PF) write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n write(suffix,"('_segment_',i3.3)") n - call get_param(PF, mdl, segnam, segstr) + ! needs documentation !! + call get_param(PF, mdl, segnam, segstr, 'xyz') call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) if (num_fields == 0) then @@ -508,6 +513,8 @@ subroutine initialize_segment_data(G, OBC, PF) IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + ! this is hard-coded for now - needs cleanup ### + brushcutter_mode = .false. do m=1,num_fields call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) @@ -525,16 +532,25 @@ subroutine initialize_segment_data(G, OBC, PF) call field_size(filename,fieldname,siz,no_domain=.true.) if (siz(4) == 1) segment%values_needed = .false. if (segment%on_pe) then - if (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0) then + if (brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then call MOM_error(FATAL,'segment data are not on the supergrid') endif siz2(1)=1 + if (siz(1)>1) then - siz2(1)=(siz(1)-1)/2 + if (brushcutter_mode) then + siz2(1)=(siz(1)-1)/2 + else + siz2(1)=siz(1) + endif endif siz2(2)=1 if (siz(2)>1) then - siz2(2)=(siz(2)-1)/2 + if (brushcutter_mode) then + siz2(2)=(siz(2)-1)/2 + else + siz2(2)=siz(2) + endif endif siz2(3)=siz(3) @@ -1935,6 +1951,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) real, dimension(:,:,:), allocatable :: tmp_buffer logical :: brushcutter_mode integer :: subsample_factor + integer :: is_obc2, js_obc2 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2024,9 +2041,25 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (.not.associated(segment%field(m)%buffer_dst)) then if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') if (segment%field(m)%nk_src > 1) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + if (brushcutter_mode) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + else + if (segment%is_E_or_W) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) + else + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) + endif + endif else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + if (brushcutter_mode) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + else + if (segment%is_E_or_W) then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) + else + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) + endif + endif endif segment%field(m)%buffer_dst(:,:,:)=0.0 if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then @@ -2070,20 +2103,38 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) endif endif - do j=js_obc,je_obc - do i=is_obc,ie_obc + if (segment%is_E_or_W) then + ishift=1 + if (segment%direction == OBC_DIRECTION_E) ishift=0 + do j=js_obc+1,je_obc + I=is_obc ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(i,j,:)=0.0 ! initialize remap destination buffer - if (G%mask2dT(i,j)>0.) then + segment%field(m)%buffer_dst(I,j,:)=0.0 ! initialize remap destination buffer + if (G%mask2dCu(I,j)>0.) then call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(i,j,:), & - segment%field(m)%buffer_src(i,j,:), & - G%ke, h(i,j,:), segment%field(m)%buffer_dst(i,j,:)) + segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & + segment%field(m)%buffer_src(I,j,:), & + G%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) endif enddo - enddo + else + jshift=1 + if (segment%direction == OBC_DIRECTION_N) jshift=0 + do i=is_obc+1,ie_obc + J=js_obc + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(i,J,:)=0.0 ! initialize remap destination buffer + if (G%mask2dCv(i,J)>0.) then + call remapping_core_h(OBC%remap_CS, & + segment%field(m)%nk_src,segment%field(m)%dz_src(i,J,:), & + segment%field(m)%buffer_src(i,J,:), & + G%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) + endif + enddo + endif else ! 2d data segment%field(m)%buffer_dst(:,:,1)=segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer endif @@ -2099,12 +2150,29 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif endif + ! from this point on, data are entirely on segments - will + ! write all segment loops as 2d loops. + if (segment%is_E_or_W) then + js_obc2 = js_obc+1 + is_obc2 = is_obc + else + js_obc2 = js_obc + is_obc2 = is_obc+1 + endif + if (segment%is_N_or_S) then + is_obc2 = is_obc+1 + js_obc2 = js_obc + else + is_obc2 = is_obc + js_obc2 = js_obc+1 + endif + if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then if (segment%field(m)%fid>0) then ! calculate external BT velocity and transport if needed if((trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) .or. & (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S)) then - do j=js_obc,je_obc - do i=is_obc,ie_obc + do j=js_obc2,je_obc + do i=is_obc2,ie_obc segment%normal_trans_bt(i,j) = 0.0 do k=1,G%ke segment%normal_vel(i,j,k) = segment%field(m)%buffer_dst(i,j,k) @@ -2120,8 +2188,8 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif if (trim(segment%field(m)%name) == 'SSH') then - do j=js_obc,je_obc - do i=is_obc,ie_obc + 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 @@ -2129,7 +2197,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (trim(segment%field(m)%name) == 'TEMP') then if (associated(segment%field(m)%buffer_dst)) then - do k=1,nz; do j=js_obc, je_obc;do i=is_obc,ie_obc + do k=1,nz; do j=js_obc2, je_obc;do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) enddo; enddo; enddo else @@ -2137,7 +2205,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif elseif (trim(segment%field(m)%name) == 'SALT') then if (associated(segment%field(m)%buffer_dst)) then - do k=1,nz; do j=js_obc, je_obc;do i=is_obc,ie_obc + do k=1,nz; do j=js_obc2, je_obc;do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) enddo; enddo; enddo else From e0efd880b6b834f6114623cb1c16d4f76563fffc Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 20 Dec 2017 16:20:49 -0500 Subject: [PATCH 073/170] Nudging parameters for OBCs --- src/core/MOM_open_boundary.F90 | 102 +++++++++++++++++++++++++++++++-- 1 file changed, 98 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index a9c7bec4bf..9551642103 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -653,16 +653,18 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) end subroutine setup_segment_indices !> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly -subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) +subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" integer, intent(in) :: l_seg !< which segment is this? + type(param_file_type), intent(in) , optional :: PF ! Local variables integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space integer :: j, a_loop character(len=32) :: action_str(5) - + character(len=128) :: seg_str, segment_param_str + real, dimension(2) :: tnudge ! This returns the global indices for the segment call parse_segment_str(G%ieg, G%jeg, segment_str, I_obc, Js_obc, Je_obc, action_str ) @@ -709,8 +711,16 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) OBC%open_u_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. - OBC%segment(l_seg)%Tnudge_in = 1.0/(3*86400) - OBC%segment(l_seg)%Tnudge_out = 1.0/(360*86400) + write(segment_param_str(1:22),"('OBC_SEGMENT_',i3.3,'_TNUDGE')") l_seg + print *,'segment_param_str= ',segment_param_str(1:22) + call get_param(PF, mdl, segment_param_str(1:22), tnudge, & + "Timescales in seconds for nudging along a segment", & + fail_if_missing=.true.,default=0.,units="days") +! tnudge(1)=1.0;tnudge(2)=30. + print *,'tnudge=',tnudge +! call parse_segment_param(seg_str, 'TNUDGE_UNITS',OBC%segment(l_seg)%Tnudge_in) + OBC%segment(l_seg)%Tnudge_in = 1.0/(tnudge(1)*86400.) + OBC%segment(l_seg)%Tnudge_out = 1.0/(tnudge(2)*86400.) OBC%nudged_u_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. @@ -1032,6 +1042,90 @@ subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fi end subroutine parse_segment_data_str + +!> Parse an OBC_SEGMENT_%%%_PARAMS string + subroutine parse_segment_param_real(segment_str, var, param_value, debug ) + character(len=*), intent(in) :: segment_str !< A string in form of "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed + real, intent(out) :: param_value !< The value of the parameter + logical, intent(in), optional :: debug + ! Local variables + character(len=128) :: word1, word2, word3, method + integer :: lword, nfields, n, m, orient + logical :: continue,dbg + character(len=32), dimension(MAX_OBC_FIELDS) :: flds + + nfields=0 + continue=.true. + dbg=.false. + if (PRESENT(debug)) dbg=debug + + do while (continue) + word1 = extract_word(segment_str,',',nfields+1) + if (trim(word1) == '') exit + nfields=nfields+1 + word2 = extract_word(word1,'=',1) + flds(nfields) = trim(word2) + enddo + + ! if (PRESENT(fields)) then + ! do n=1,nfields + ! fields(n) = flds(n) + ! enddo + ! endif + + ! if (PRESENT(num_fields)) then + ! num_fields=nfields + ! return + ! endif + + m=0 +! if (PRESENT(var)) then + do n=1,nfields + if (trim(var)==trim(flds(n))) then + m=n + exit + endif + enddo + if (m==0) then + call abort() + endif + + print *,'00001x' + ! Process first word which will start with the fieldname + word3 = extract_word(segment_str,',',m) +! word1 = extract_word(word3,':',1) +! if (trim(word1) == '') exit + word2 = extract_word(word1,'=',1) + if (trim(word2) == trim(var)) then + method=trim(extract_word(word1,'=',2)) + lword=len_trim(method) + read(method(1:lword),*,err=987) param_value + print *,'00002x' + ! if (method(lword-3:lword) == 'file') then + ! ! raise an error id filename/fieldname not in argument list + ! word1 = extract_word(word3,':',2) + ! filenam = extract_word(word1,'(',1) + ! fieldnam = extract_word(word1,'(',2) + ! lword=len_trim(fieldnam) + ! fieldnam = fieldnam(1:lword-1) ! remove trailing parenth + ! value=-999. + ! elseif (method(lword-4:lword) == 'value') then + ! filenam = 'none' + ! fieldnam = 'none' + ! word1 = extract_word(word3,':',2) + ! lword=len_trim(word1) + ! read(word1(1:lword),*,end=986,err=987) value + ! endif + endif +! endif + + return + 986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) + 987 call MOM_error(FATAL,'Error while parsing segment parameter specification! '//trim(segment_str)) + + end subroutine parse_segment_param_real + !> Initialize open boundary control structure subroutine open_boundary_init(G, param_file, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure From 3dc2b34c147f6f5deb4336f08c247bc86a4cbafd Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 21 Dec 2017 15:28:06 -0500 Subject: [PATCH 074/170] fixes to read nudging timescales via MOM_parser --- src/core/MOM_open_boundary.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9551642103..f3e954f2f0 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -356,9 +356,9 @@ subroutine open_boundary_config(G, param_file, OBC) fail_if_missing=.true.) segment_str = remove_spaces(segment_str) if (segment_str(1:2) == 'I=') then - call setup_u_point_obc(OBC, G, segment_str, l) + call setup_u_point_obc(OBC, G, segment_str, l, param_file) elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, segment_str, l) + call setup_v_point_obc(OBC, G, segment_str, l, param_file) else call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) @@ -658,13 +658,13 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" integer, intent(in) :: l_seg !< which segment is this? - type(param_file_type), intent(in) , optional :: PF + type(param_file_type), intent(in) :: PF ! Local variables integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space integer :: j, a_loop character(len=32) :: action_str(5) character(len=128) :: seg_str, segment_param_str - real, dimension(2) :: tnudge + real, allocatable, dimension(:) :: tnudge ! This returns the global indices for the segment call parse_segment_str(G%ieg, G%jeg, segment_str, I_obc, Js_obc, Je_obc, action_str ) @@ -713,6 +713,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) OBC%segment(l_seg)%nudged = .true. write(segment_param_str(1:22),"('OBC_SEGMENT_',i3.3,'_TNUDGE')") l_seg print *,'segment_param_str= ',segment_param_str(1:22) + allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:22), tnudge, & "Timescales in seconds for nudging along a segment", & fail_if_missing=.true.,default=0.,units="days") @@ -721,6 +722,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) ! call parse_segment_param(seg_str, 'TNUDGE_UNITS',OBC%segment(l_seg)%Tnudge_in) OBC%segment(l_seg)%Tnudge_in = 1.0/(tnudge(1)*86400.) OBC%segment(l_seg)%Tnudge_out = 1.0/(tnudge(2)*86400.) + deallocate(tnudge) OBC%nudged_u_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. @@ -765,11 +767,12 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) end subroutine setup_u_point_obc !> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly -subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) +subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" integer, intent(in) :: l_seg !< which segment is this? + type(param_file_type), intent(in) :: PF ! Local variables integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space integer :: i, a_loop From 27c78d1af67a323e47dcb4371fc09a4b21993a60 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 22 Dec 2017 11:33:51 -0900 Subject: [PATCH 075/170] Add a DUMBBELL_FRACTION parameter. --- src/user/dumbbell_initialization.F90 | 63 ++++++++++++---------------- 1 file changed, 27 insertions(+), 36 deletions(-) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index db730b4dbb..f06da3a3bf 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -50,25 +50,26 @@ subroutine dumbbell_initialize_topography ( D, G, param_file, max_depth ) ! Local variables integer :: i, j - real :: x, y, delta, dblen - + real :: x, y, delta, dblen, dbfrac call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & - 'Lateral Length scale for dumbbell ',& + 'Lateral Length scale for dumbbell.',& units='k', default=600., do_not_log=.false.) + call get_param(param_file, mdl,"DUMBBELL_FRACTION",dbfrac, & + 'Meridional fraction for narrow part of dumbbell.',& + units='nondim', default=0.5, do_not_log=.false.) if (G%x_axis_units == 'm') then dblen=dblen*1.e3 endif - do i=G%isc,G%iec do j=G%jsc,G%jec ! Compute normalized zonal coordinates (x,y=0 at center of domain) x = ( G%geoLonT(i,j) ) / dblen y = ( G%geoLatT(i,j) ) / G%len_lat D(i,j)=G%max_depth - if ((x>=-0.25 .and. x<=0.25) .and. (y<=-.25 .or. y>=0.25)) then + if ((x>=-0.25 .and. x<=0.25) .and. (y <= -0.5*dbfrac .or. y >= 0.5*dbfrac)) then D(i,j) = 0.0 endif enddo @@ -229,32 +230,29 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file dblen=dblen*1.e3 endif + do j=G%jsc,G%jec + do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / dblen + do k=1,nz + T(i,j,k)=T_surf + enddo + if (x>=0. ) then + do k=1,nz + S(i,j,k)=S_surf + 0.5*S_range + enddo + endif + if (x<0. ) then + do k=1,nz + S(i,j,k)=S_surf - 0.5*S_range + enddo + endif - - do j=G%jsc,G%jec - do i=G%isc,G%iec - ! Compute normalized zonal coordinates (x,y=0 at center of domain) - x = ( G%geoLonT(i,j) ) / dblen - do k=1,nz - T(i,j,k)=T_surf - enddo - if (x>=0. ) then - do k=1,nz - S(i,j,k)=S_surf + 0.5*S_range - enddo - endif - if (x<0. ) then - do k=1,nz - S(i,j,k)=S_surf - 0.5*S_range - enddo - endif - - enddo - enddo + enddo + enddo end subroutine dumbbell_initialize_temperature_salinity - !> Initialize the restoring sponges for the dense water experiment subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure @@ -282,7 +280,6 @@ subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp dblen=dblen*1.e3 endif - nz = GV%ke call get_param(param_file, mdl, "DUMBBELL_SPONGE_TIME_SCALE", sponge_time_scale, & @@ -294,7 +291,6 @@ subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp 'Minimum thickness for layer',& units='m', default=1.0e-3, do_not_log=.true.) - ! no active sponges if (sponge_time_scale <= 0.) return @@ -329,10 +325,8 @@ subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp enddo enddo ; enddo - call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) - ! construct temperature and salinity for the sponge ! start with initial condition S(:,:,:) = 0.0 @@ -340,7 +334,6 @@ subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp do j=G%jsc,G%jec do i=G%isc,G%iec - ! Compute normalized zonal coordinates (x,y=0 at center of domain) x = ( G%geoLonT(i,j) ) / dblen if (x>=0.25 ) then @@ -356,15 +349,13 @@ subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp ! if (j.eq.G%jsc) print *,'i,Sponge S= ',i,S(i,1,1) enddo - enddo - endif + endif - if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, tv%S, ACSp) + if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, tv%S, ACSp) end subroutine dumbbell_initialize_sponges - !> \namespace dumbbell_initialization !! !! The module configures the model for the idealized dumbbell From c94bc932ae1ac6e683d3438b9e95edd8ae340816 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 26 Dec 2017 15:44:12 -0500 Subject: [PATCH 076/170] Passing the runoff iron and geothermal heat fluxes to ocean biogeochem - COBALT is updated to get the iron flux in frozen runoff (proxy to bergs iron) and the geothermal heat flux. --- src/tracer/MOM_generic_tracer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 891f29dbbd..3fe9eb25c6 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -614,7 +614,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, call generic_tracer_source(tv%T,tv%S,rho_dzt,dzt,Hml,G%isd,G%jsd,1,dt,& G%areaT,get_diag_time_end(CS%diag),& - optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, sosga=sosga) + optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, tv%internal_heat, fluxes%frunoff, sosga=sosga) ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes ! usually in ALE mode From ee26ee36cab4dfc400d53777e2d66eb11dfe8747 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 26 Dec 2017 18:09:15 -0900 Subject: [PATCH 077/170] Added brushcutter mode option. --- config_src/solo_driver/MOM_driver.F90 | 5 ---- src/core/MOM_open_boundary.F90 | 36 +++++++++++++-------------- 2 files changed, 17 insertions(+), 24 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index a18c2dd915..5e727ed250 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -24,8 +24,6 @@ program MOM_main !* * !********+*********+*********+*********+*********+*********+*********+** - - use time_interp_external_mod, only : time_interp_external_init use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end @@ -208,9 +206,6 @@ program MOM_main deallocate(ocean_pelist) endif - !!! dont keep this here - move to mom open_boundary ### - call time_interp_external_init() - ! These clocks are on the global pelist. initClock = cpu_clock_id( 'Initialization' ) mainClock = cpu_clock_id( 'Main loop' ) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f3e954f2f0..07dd1d6f91 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -21,6 +21,7 @@ module MOM_open_boundary use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs use time_interp_external_mod, only : init_external_field, time_interp_external +use time_interp_external_mod, only : time_interp_external_init use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping use MOM_regridding, only : regridding_CS @@ -181,6 +182,7 @@ module MOM_open_boundary logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for !! use in the biharmonic viscosity term. logical :: extend_segments = .false. !< If True, extend OBC segments (for testing) + logical :: brushcutter_mode = .false. !< If True, read data on supergrid. real :: g_Earth ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & @@ -402,6 +404,9 @@ subroutine open_boundary_config(G, param_file, OBC) OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) then ! No open boundaries have been requested call open_boundary_dealloc(OBC) + else + ! Need this for ocean_only mode boundary interpolation. + call time_interp_external_init() endif end subroutine open_boundary_config @@ -432,9 +437,6 @@ subroutine initialize_segment_data(G, OBC, PF) integer :: current_pe integer, dimension(1) :: single_pelist !will be able to dynamically switch between sub-sampling refined grid data or model grid - logical :: brushcutter_mode - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -463,6 +465,9 @@ subroutine initialize_segment_data(G, OBC, PF) "If true, the values on the intermediate grid used for remapping\n"//& "are forced to be bounded, which might not be the case due to\n"//& "round off.", default=.false.,do_not_log=.true.) + call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + "If true, read external OBC data on the supergrid.", & + default=.false.) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & @@ -471,7 +476,6 @@ subroutine initialize_segment_data(G, OBC, PF) if (OBC%user_BCs_set_globally) return - !< temporarily disable communication in order to read segment data independently allocate(saved_pelist(0:mpp_npes()-1)) @@ -513,9 +517,6 @@ subroutine initialize_segment_data(G, OBC, PF) IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - ! this is hard-coded for now - needs cleanup ### - brushcutter_mode = .false. - do m=1,num_fields call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) if (trim(filename) /= 'none') then @@ -532,13 +533,13 @@ subroutine initialize_segment_data(G, OBC, PF) call field_size(filename,fieldname,siz,no_domain=.true.) if (siz(4) == 1) segment%values_needed = .false. if (segment%on_pe) then - if (brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then + if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then call MOM_error(FATAL,'segment data are not on the supergrid') endif siz2(1)=1 if (siz(1)>1) then - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then siz2(1)=(siz(1)-1)/2 else siz2(1)=siz(1) @@ -546,7 +547,7 @@ subroutine initialize_segment_data(G, OBC, PF) endif siz2(2)=1 if (siz(2)>1) then - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then siz2(2)=(siz(2)-1)/2 else siz2(2)=siz(2) @@ -2046,7 +2047,6 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) real, dimension(:,:), pointer :: seg_vel => NULL() ! pointer to segment velocity array real, dimension(:,:), pointer :: seg_trans => NULL() ! pointer to segment transport array real, dimension(:,:,:), allocatable :: tmp_buffer - logical :: brushcutter_mode integer :: subsample_factor integer :: is_obc2, js_obc2 @@ -2057,9 +2057,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (.not. associated(OBC)) return - !will be able to dynamically switch between sub-sampling refined grid data or model grid - brushcutter_mode = .false. - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then subsample_factor = 2 else subsample_factor = 1 @@ -2076,7 +2074,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) js_obc = max(segment%js_obc,jsd-1) je_obc = min(segment%je_obc,jed) - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then if (segment%is_E_or_W) then nj_seg=nj_seg-1 js_obc=js_obc+1 @@ -2138,7 +2136,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (.not.associated(segment%field(m)%buffer_dst)) then if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') if (segment%field(m)%nk_src > 1) then - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else if (segment%is_E_or_W) then @@ -2148,7 +2146,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif endif else - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) else if (segment%is_E_or_W) then @@ -2172,7 +2170,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif call time_interp_external(segment%field(m)%fid,Time, tmp_buffer) - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then if (siz(1)==1) then segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) else @@ -2187,7 +2185,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif if (segment%field(m)%nk_src > 1) then call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer) - if (brushcutter_mode) then + if (OBC%brushcutter_mode) then if (siz(1)==1) then segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) else From 3ae0d49141250aeedcf54185327a557458851c52 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Dec 2017 10:26:53 -0500 Subject: [PATCH 078/170] +Added the new runtime parameter VEL_UNDERFLOW Added a new runtime parameter for a velocity that is so small that it is reset to zero, and use this in vertvisc_limit_vel and btstep. By default all answers are bitwise identical, but the MOM_parameter_doc.all files change. --- src/core/MOM_barotropic.F90 | 28 ++++++++- .../vertical/MOM_vert_friction.F90 | 63 +++++++++++++------ 2 files changed, 69 insertions(+), 22 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 6b93a14738..9890b7ddf6 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -304,6 +304,8 @@ module MOM_barotropic ! desperate debugging measure. logical :: debug ! If true, write verbose checksums for debugging purposes. logical :: debug_bt ! If true, write verbose checksums for debugging purposes. + real :: vel_underflow !< Velocity components smaller than vel_underflow + !! are set to 0, in m s-1. real :: maxvel ! Velocity components greater than maxvel are ! truncated to maxvel, in m s-1. real :: CFL_trunc ! If clip_velocity is true, velocity components will @@ -634,6 +636,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & real :: u_max_cor, v_max_cor ! The maximum corrective velocities, in m s-1. real :: Htot ! The total thickness, in units of H. real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta, in H. + real :: accel_underflow ! An acceleration that is so small it should be zeroed out. real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2 real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans @@ -662,6 +665,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB MS%isdw = CS%isdw ; MS%iedw = CS%iedw ; MS%jsdw = CS%jsdw ; MS%jedw = CS%jedw Idt = 1.0 / dt + accel_underflow = CS%vel_underflow * Idt use_BT_cont = .false. if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) @@ -1092,13 +1096,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary -!GOMP do + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then uhbt0(I,j) = 0.0 endif ; enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary -!GOMP do + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vhbt0(i,J) = 0.0 endif ; enddo ; enddo @@ -1122,6 +1126,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & do J=js-1,je ; do k=1,nz ; do i=is,ie vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * V_in(i,J,k) enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 + enddo ; enddo if (apply_OBCs) then ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:) @@ -1132,11 +1144,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & do j=js,je ; do I=is-1,ie BT_force_u(I,j) = BT_force_u(I,j) + (ubt(I,j) - CS%ubt_IC(I,j)) * Idt ubt(I,j) = CS%ubt_IC(I,j) + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie BT_force_v(i,J) = BT_force_v(i,J) + (vbt(i,J) - CS%vbt_IC(i,J)) * Idt vbt(i,J) = CS%vbt_IC(i,J) + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 enddo ; enddo endif @@ -1768,6 +1782,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev if (CS%linear_wave_drag) then @@ -1826,6 +1841,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev if (CS%linear_wave_drag) then u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * & @@ -1893,6 +1909,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then @@ -2135,11 +2152,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & accel_layer_u(I,j,k) = u_accel_bt(I,j) - & ((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j) - & (pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j)) * CS%IdxCu(I,j) + if (abs(accel_layer_u(I,j,k)) < accel_underflow) accel_layer_u(I,j,k) = 0.0 enddo ; enddo do J=js-1,je ; do i=is,ie accel_layer_v(i,J,k) = v_accel_bt(i,J) - & ((pbce(i,j+1,k) - gtot_S(i,j+1))*e_anom(i,j+1) - & (pbce(i,j,k) - gtot_N(i,j))*e_anom(i,j)) * CS%IdyCv(i,J) + if (abs(accel_layer_v(i,J,k)) < accel_underflow) accel_layer_v(i,J,k) = 0.0 enddo ; enddo enddo @@ -4057,6 +4076,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & "barotropic accelerations from the summed velocities \n"//& "times the time-derivatives of thicknesses.", units="nondim", & default=0.25) + call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & + "A negligibly small velocity magnitude below which velocity \n"//& + "components are set to 0. A reasonable value might be \n"//& + "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "the age of the universe.", units="m s-1", default=0.0) call get_param(param_file, mdl, "DT_BT_FILTER", CS%dt_bt_filter, & "A time-scale over which the barotropic mode solutions \n"//& diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index e0c39819a6..fee1fb456a 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -41,6 +41,8 @@ module MOM_vert_friction real :: maxvel !< Velocity components greater than maxvel, !! in m s-1, are truncated. + real :: vel_underflow !< Velocity components smaller than vel_underflow + !! are set to 0, in m s-1. logical :: CFL_based_trunc !< If true, base truncations on CFL numbers, not !! absolute velocities. real :: CFL_trunc !< Velocity components will be truncated when they @@ -1300,6 +1302,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) if (CS%CFL_based_trunc) then do I=Isq,Ieq ; vel_report(i,j) = 3.0e8 ; enddo ! Speed of light default. do k=1,nz ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) u(I,j,k) = 0.0 if (u(I,j,k) < 0.0) then CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else @@ -1313,9 +1316,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) enddo ; enddo else do I=Isq,Ieq; vel_report(I,j) = maxvel; enddo - do k=1,nz ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then - dowrite(I,j) = .true. ; trunc_any = .true. - endif ;enddo ; enddo + do k=1,nz ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 + elseif (abs(u(I,j,k)) > maxvel) then + dowrite(I,j) = .true. ; trunc_any = .true. + endif + enddo ; enddo endif do I=Isq,Ieq ; if (dowrite(I,j)) then @@ -1339,11 +1345,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) endif ; enddo ; enddo endif ; endif enddo ! j-loop - else + else ! Do not report accelerations leading to large velocities. if (CS%CFL_based_trunc) then !$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,dt,G,CS,h,H_report) do k=1,nz ; do j=js,je ; do I=Isq,Ieq - if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then @@ -1353,10 +1360,13 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) enddo ; enddo ; enddo else !$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,G,CS,truncvel,maxvel,h,H_report) - do k=1,nz ; do j=js,je ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then - u(I,j,k) = SIGN(truncvel,u(I,j,k)) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo ; enddo + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 + elseif (abs(u(I,j,k)) > maxvel) then + u(I,j,k) = SIGN(truncvel,u(I,j,k)) + if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo endif endif @@ -1378,6 +1388,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) if (CS%CFL_based_trunc) then do i=is,ie ; vel_report(i,J) = 3.0e8 ; enddo ! Speed of light default. do k=1,nz ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) v(i,J,k) = 0.0 if (v(i,J,k) < 0.0) then CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else @@ -1391,9 +1402,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) enddo ; enddo else do i=is,ie ; vel_report(i,J) = maxvel ; enddo - do k=1,nz ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then - dowrite(i,J) = .true. ; trunc_any = .true. - endif ; enddo ; enddo + do k=1,nz ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 + elseif (abs(v(i,J,k)) > maxvel) then + dowrite(i,J) = .true. ; trunc_any = .true. + endif + enddo ; enddo endif do i=is,ie ; if (dowrite(i,J)) then @@ -1417,11 +1431,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) endif ; enddo ; enddo endif ; endif enddo ! J-loop - else + else ! Do not report accelerations leading to large velocities. if (CS%CFL_based_trunc) then -!$OMP parallel do default(none) shared(is,ie,Jsq,Jeq,nz,v,dt,G,CS,h,H_report) + !$OMP parallel do default(shared) do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then @@ -1430,11 +1445,14 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) endif enddo ; enddo ; enddo else -!$OMP parallel do default(none) shared(is,ie,Jsq,Jeq,nz,v,G,CS,h,truncvel,maxvel,H_report) - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then - v(i,J,k) = SIGN(truncvel,v(i,J,k)) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 + elseif (abs(v(i,J,k)) > maxvel) then + v(i,J,k) = SIGN(truncvel,v(i,J,k)) + if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo endif endif @@ -1594,6 +1612,11 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & "The start value of the truncation CFL number used when\n"//& "ramping up CFL_TRUNC.", & units="nondim", default=0.) + call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & + "A negligibly small velocity magnitude below which velocity \n"//& + "components are set to 0. A reasonable value might be \n"//& + "1e-30 m/s, which is less than an Angstrom divided by \n"//& + "the age of the universe.", units="m s-1", default=0.0) ALLOC_(CS%a_u(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u(:,:,:) = 0.0 ALLOC_(CS%h_u(IsdB:IedB,jsd:jed,nz)) ; CS%h_u(:,:,:) = 0.0 From 3b1630fb938daaa1234a7510f82ed01b5dec8d41 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Dec 2017 10:27:51 -0500 Subject: [PATCH 079/170] Convert thickness transport diagnostic units Converted the units of the native-grid explicit thickness transports, uh and vh, so that the values that are written out do not change their units when H_to_m changes. All solutions are bitwise identical, but the values of these diagnostics change when H_TO_M (or H_TO_KG_M2 if non-Boussinesq) is not 1. --- src/core/MOM_dynamics_split_RK2.F90 | 8 ++++++-- src/core/MOM_dynamics_unsplit.F90 | 8 ++++++-- src/core/MOM_dynamics_unsplit_RK2.F90 | 8 ++++++-- 3 files changed, 18 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 72f4b7c178..c9c148be9e 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -950,6 +950,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_fil real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tmp character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units, eta_rest_name + real :: H_convert type(group_pass_type) :: pass_av_h_uvh logical :: use_tides, debug_truncations @@ -1108,10 +1109,13 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_fil call cpu_clock_end(id_clock_pass_init) flux_units = get_flux_units(GV) + H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true.) + 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & + conversion=H_convert) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true.) + 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & + conversion=H_convert) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration', 'm s-2') diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index a90751fb44..0eadfb130f 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -664,6 +664,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, param_file, diag, CS, & ! dynamic core, including diagnostics and the cpu clocks. character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units + real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke @@ -714,10 +715,13 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, param_file, diag, CS, & if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp flux_units = get_flux_units(GV) + H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true.) + 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & + conversion=H_convert) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true.) + 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & + conversion=H_convert) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration', 'meter second-2') CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index c85a544942..1639f6d512 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -611,6 +611,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, param_file, diag, CS ! dynamic core, including diagnostics and the cpu clocks. character(len=40) :: mdl = "MOM_dynamics_unsplit_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units + real :: H_convert logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke @@ -676,10 +677,13 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, param_file, diag, CS if (associated(OBC)) CS%OBC => OBC flux_units = get_flux_units(GV) + H_convert = GV%H_to_m ; if (.not.GV%Boussinesq) H_convert = GV%H_to_kg_m2 CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & - 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true.) + 'Zonal Thickness Flux', flux_units, y_cell_method='sum', v_extensive=.true., & + conversion=H_convert) CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & - 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true.) + 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & + conversion=H_convert) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration', 'meter second-2') CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & From 5c3850f6407e1eaf209fb09d56f86f0a1ecdf2da Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Dec 2017 10:28:41 -0500 Subject: [PATCH 080/170] Convert energy and heat flux diagnostic units Converted the units of the various energy budget terms, heat and salt fluxes, layer thicknesses and certain mass fluxes so that the values that are written out do not change their units when H_to_m changes. All solutions are bitwise identical, but the values of these diagnostics change when H_TO_M (or H_TO_KG_M2 for non-Boussinesq models) is not 1, and a new GV argument is added to the interface for calculate_energy_diagnostics. --- src/core/MOM.F90 | 32 ++++++++++++------- src/diagnostics/MOM_diagnostics.F90 | 49 +++++++++++++++-------------- src/framework/MOM_diag_remap.F90 | 10 +++--- 3 files changed, 53 insertions(+), 38 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a16f51c139..41351b9b5e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2338,7 +2338,7 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) type(accel_diag_ptrs), intent(inout) :: ADp !< structure pointing to accelerations in momentum equation real, intent(in) :: C_p !< Heat capacity used in conversion to watts - real :: conv2watt, conv2salt + real :: conv2watt, conv2salt, H_convert character(len=48) :: thickness_units, flux_units, S_flux_units type(diag_ctrl), pointer :: diag integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz @@ -2351,8 +2351,13 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) flux_units = get_flux_units(GV) S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? conv2watt = GV%H_to_kg_m2 * C_p - conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001 and remove the following line? - if (.not.GV%Boussinesq) conv2salt = GV%H_to_kg_m2 + if (GV%Boussinesq) then + conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? + H_convert = GV%H_to_m + else + conv2salt = GV%H_to_kg_m2 + H_convert = GV%H_to_kg_m2 + endif !Initialize the diagnostics mask arrays. !This has to be done after MOM_initialize_state call. @@ -2365,7 +2370,7 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) 'Meridional velocity', 'm s-1', cmor_field_name='vo', & cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') CS%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & - 'Layer Thickness', thickness_units, v_extensive=.true.) + 'Layer Thickness', thickness_units, v_extensive=.true., conversion=H_convert) CS%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& long_name='Total volume of liquid ocean', units='m3', & @@ -2479,7 +2484,8 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) 'Diffusive Zonal Flux of Salt', S_flux_units, & v_extensive = .true., conversion = conv2salt) CS%id_Sdiffy = register_diag_field('ocean_model', 'S_diffy', diag%axesCvL, Time, & - 'Diffusive Meridional Flux of Salt', S_flux_units, v_extensive = .true.) + 'Diffusive Meridional Flux of Salt', S_flux_units, & + v_extensive = .true., conversion = conv2salt) if (CS%id_Sadx > 0) call safe_alloc_ptr(CS%S_adx,IsdB,IedB,jsd,jed,nz) if (CS%id_Sady > 0) call safe_alloc_ptr(CS%S_ady,isd,ied,JsdB,JedB,nz) if (CS%id_Sdiffx > 0) call safe_alloc_ptr(CS%S_diffx,IsdB,IedB,jsd,jed,nz) @@ -2488,13 +2494,17 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) ! vertically integrated lateral heat advective and diffusive fluxes CS%id_Tadx_2d = register_diag_field('ocean_model', 'T_adx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Advective Zonal Flux of Heat', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Advective Zonal Flux of Heat', 'W m-2', & + conversion = conv2watt) CS%id_Tady_2d = register_diag_field('ocean_model', 'T_ady_2d', diag%axesCv1, Time, & - 'Vertically Integrated Advective Meridional Flux of Heat', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Advective Meridional Flux of Heat', 'W m-2', & + conversion = conv2watt) CS%id_Tdiffx_2d = register_diag_field('ocean_model', 'T_diffx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Diffusive Zonal Flux of Heat', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Diffusive Zonal Flux of Heat', 'W m-2', & + conversion = conv2watt) CS%id_Tdiffy_2d = register_diag_field('ocean_model', 'T_diffy_2d', diag%axesCv1, Time, & - 'Vertically Integrated Diffusive Meridional Flux of Heat', 'W m-2', conversion = conv2watt) + 'Vertically Integrated Diffusive Meridional Flux of Heat', 'W m-2', & + conversion = conv2watt) if (CS%id_Tadx_2d > 0) call safe_alloc_ptr(CS%T_adx_2d,IsdB,IedB,jsd,jed) if (CS%id_Tady_2d > 0) call safe_alloc_ptr(CS%T_ady_2d,isd,ied,JsdB,JedB) if (CS%id_Tdiffx_2d > 0) call safe_alloc_ptr(CS%T_diffx_2d,IsdB,IedB,jsd,jed) @@ -2527,10 +2537,10 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) ! Diagnostics related to tracer transport CS%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & 'Accumulated zonal thickness fluxes to advect tracers', 'kg', & - y_cell_method='sum', v_extensive=.true.) + y_cell_method='sum', v_extensive=.true., conversion=H_convert) CS%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & 'Accumulated meridional thickness fluxes to advect tracers', 'kg', & - x_cell_method='sum', v_extensive=.true.) + x_cell_method='sum', v_extensive=.true., conversion=H_convert) CS%id_umo = register_diag_field('ocean_model', 'umo', & diag%axesCuL, Time, 'Ocean Mass X Transport', 'kg s-1', & standard_name='ocean_mass_x_transport', y_cell_method='sum', v_extensive=.true.) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 218fdb938f..920dbf9ba8 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -10,8 +10,6 @@ module MOM_diagnostics !* that are not calculated in the various subroutines. Diagnostic * !* quantities are requested by allocating them memory. * !* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * !* A small fragment of the grid is shown below: * !* * !* j+1 x ^ x ^ x At x: q, CoriolisBu * @@ -599,7 +597,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_dh_dt>0) call post_data(CS%id_dh_dt, CS%dh_dt, CS%diag) - call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) + call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) endif end subroutine calculate_diagnostic_fields @@ -799,8 +797,10 @@ subroutine calculate_vertical_integrals(h, tv, fluxes, G, GV, CS) end subroutine calculate_vertical_integrals !> This subroutine calculates terms in the mechanical energy budget. -subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) +subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) type(ocean_grid_type), intent(inout) :: 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)), intent(in) :: u !< The zonal velocity, in m s-1. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, !! in m s-1. @@ -879,8 +879,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie - CS%dKE_dt(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) * & - (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + CS%dKE_dt(i,j,k) = GV%H_to_m * (KE_h(i,j) + 0.5 * G%IareaT(i,j) * & + (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo if (CS%id_dKEdt > 0) call post_data(CS%id_dKEdt, CS%dKE_dt, CS%diag) @@ -897,7 +897,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie - CS%PE_to_KE(i,j,k) = 0.5 * G%IareaT(i,j) * & + CS%PE_to_KE(i,j,k) = GV%H_to_m * 0.5 * G%IareaT(i,j) * & (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) enddo ; enddo enddo @@ -919,8 +919,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie - CS%KE_CorAdv(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) * & - (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + CS%KE_CorAdv(i,j,k) = GV%H_to_m * (KE_h(i,j) + 0.5 * G%IareaT(i,j) * & + (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo if (CS%id_KE_Coradv > 0) call post_data(CS%id_KE_Coradv, CS%KE_Coradv, CS%diag) @@ -941,8 +941,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie - CS%KE_adv(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) * & - (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + CS%KE_adv(i,j,k) = GV%H_to_m * (KE_h(i,j) + 0.5 * G%IareaT(i,j) * & + (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo if (CS%id_KE_adv > 0) call post_data(CS%id_KE_adv, CS%KE_adv, CS%diag) @@ -959,8 +959,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie - CS%KE_visc(i,j,k) = 0.5 * G%IareaT(i,j) * & - (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + CS%KE_visc(i,j,k) = GV%H_to_m * (0.5 * G%IareaT(i,j) * & + (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo if (CS%id_KE_visc > 0) call post_data(CS%id_KE_visc, CS%KE_visc, CS%diag) @@ -977,7 +977,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie - CS%KE_horvisc(i,j,k) = 0.5 * G%IareaT(i,j) * & + CS%KE_horvisc(i,j,k) = GV%H_to_m * 0.5 * G%IareaT(i,j) * & (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) enddo ; enddo enddo @@ -999,7 +999,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, CS) if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie - CS%KE_dia(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) * & + CS%KE_dia(i,j,k) = KE_h(i,j) + GV%H_to_m * 0.5 * G%IareaT(i,j) * & (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) enddo ; enddo enddo @@ -1110,7 +1110,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS #include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. - real :: omega, f2_min + real :: omega, f2_min, convert_H character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j @@ -1141,9 +1141,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS units='m', default=-1.) if (GV%Boussinesq) then - thickness_units = "m" ; flux_units = "m3 s-1" + thickness_units = "m" ; flux_units = "m3 s-1" ; convert_H = GV%H_to_m else - thickness_units = "kg m-2" ; flux_units = "kg s-1" + thickness_units = "kg m-2" ; flux_units = "kg s-1" ; convert_H = GV%H_to_kg_m2 endif CS%id_temp_layer_ave = register_diag_field('ocean_model', 'temp_layer_ave', diag%axesZL, Time, & @@ -1237,25 +1237,28 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & - 'Layer thicknesses in pure potential density coordinates', thickness_units) + 'Layer thicknesses in pure potential density coordinates', thickness_units, & + conversion=convert_H) if (CS%id_h_Rlay>0) call safe_alloc_ptr(CS%h_Rlay,isd,ied,jsd,jed,nz) CS%id_uh_Rlay = register_diag_field('ocean_model', 'uh_rho', diag%axesCuL, Time, & - 'Zonal volume transport in pure potential density coordinates', flux_units) + 'Zonal volume transport in pure potential density coordinates', flux_units, & + conversion=convert_H) if (CS%id_uh_Rlay>0) call safe_alloc_ptr(CS%uh_Rlay,IsdB,IedB,jsd,jed,nz) CS%id_vh_Rlay = register_diag_field('ocean_model', 'vh_rho', diag%axesCvL, Time, & - 'Meridional volume transport in pure potential density coordinates', flux_units) + 'Meridional volume transport in pure potential density coordinates', flux_units, & + conversion=convert_H) if (CS%id_vh_Rlay>0) call safe_alloc_ptr(CS%vh_Rlay,isd,ied,JsdB,JedB,nz) CS%id_uhGM_Rlay = register_diag_field('ocean_model', 'uhGM_rho', diag%axesCuL, Time, & 'Zonal volume transport due to interface height diffusion in pure potential & - &density coordinates', flux_units) + &density coordinates', flux_units, conversion=convert_H) if (CS%id_uhGM_Rlay>0) call safe_alloc_ptr(CS%uhGM_Rlay,IsdB,IedB,jsd,jed,nz) CS%id_vhGM_Rlay = register_diag_field('ocean_model', 'vhGM_rho', diag%axesCvL, Time, & 'Meridional volume transport due to interface height diffusion in pure & - &potential density coordinates', flux_units) + &potential density coordinates', flux_units, conversion=convert_H) if (CS%id_vhGM_Rlay>0) call safe_alloc_ptr(CS%vhGM_Rlay,isd,ied,JsdB,JedB,nz) !endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index ab50a1fb92..cea3a22c87 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -222,14 +222,15 @@ function diag_remap_axes_configured(remap_cs) !! target grid whenever T/S change. subroutine diag_remap_update(remap_cs, G, h, T, S, eqn_of_state) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure - type(ocean_grid_type), pointer :: G !< The ocean's grid type + type(ocean_grid_type), pointer :: G !< The ocean's grid type real, dimension(:, :, :), intent(in) :: h, T, S !< New thickness, T and S - type(EOS_type), pointer, intent(in) :: eqn_of_state !< A pointer to the equation of state + type(EOS_type), pointer, intent(in) :: eqn_of_state !< A pointer to the equation of state ! Local variables - integer :: i, j, k, nz real, dimension(remap_cs%nz + 1) :: zInterfaces real, dimension(remap_cs%nz) :: resolution + real :: h_neglect, h_neglect_edge + integer :: i, j, k, nz ! Note that coordinateMode('LAYER') is never 'configured' so will ! always return here. @@ -237,6 +238,7 @@ subroutine diag_remap_update(remap_cs, G, h, T, S, eqn_of_state) return endif + h_neglect = 1.0e-30 ; h_neglect_edge = 1.0e-10 !### Try using values from GV? nz = remap_cs%nz if (.not. remap_cs%initialized) then @@ -265,7 +267,7 @@ subroutine diag_remap_update(remap_cs, G, h, T, S, eqn_of_state) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & G%bathyT(i,j), h(i,j,:), T(i, j, :), S(i, j, :), & - eqn_of_state, zInterfaces) + eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then ! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & ! G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) From 27caf408a0dfefc2708ee278e29b36ce3daf521f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 2 Jan 2018 14:55:18 -0500 Subject: [PATCH 081/170] Clarified units in coord_zlike Added comments clarifying variable units in coord_zlike. All answers are bitwise identical. --- src/ALE/coord_zlike.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90 index 6cc3577f5a..eb3bed51d6 100644 --- a/src/ALE/coord_zlike.F90 +++ b/src/ALE/coord_zlike.F90 @@ -8,16 +8,16 @@ module coord_zlike implicit none ; private !> Control structure containing required parameters for a z-like coordinate -type, public :: zlike_CS - private +type, public :: zlike_CS ; private !> Number of levels integer :: nk - !> Minimum thickness allowed for layers + !> Minimum thickness allowed for layers, in the same thickness units that will + !! be used in all subsequent calls to build_zstar_column with this structure. real :: min_thickness - !> Target coordinate resolution + !> Target coordinate resolution, usually in m real, allocatable, dimension(:) :: coordinateResolution end type zlike_CS @@ -59,21 +59,23 @@ end subroutine set_zlike_params !> Builds a z* coordinate with a minimum thickness subroutine build_zstar_column(CS, nz, depth, total_thickness, zInterface, & - z_rigid_top, eta_orig, zScale) + z_rigid_top, eta_orig, zScale) type(zlike_CS), intent(in) :: CS !< Coordinate control structure integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive in m or H) - real, intent(in) :: total_thickness !< Column thickness (positive in m or H) + real, intent(in) :: total_thickness !< Column thickness (positive in the same units as depth) real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces - real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (negative in m or H) - real, optional, intent(in) :: eta_orig !< The actual original height of the top (m or H) - real, optional, intent(in) :: zScale !< Scaling factor from the input thicknesses in m - !! to desired units for zInterface, perhaps m_to_H. + real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (negative in the same units as depth) + real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same units as depth + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution + !! in m to desired units for zInterface, perhaps m_to_H ! Local variables real :: eta, stretching, dh, min_thickness, z0_top, z_star, z_scale integer :: k logical :: new_zstar_def + z_scale = 1.0 ; if (present(zScale)) z_scale = zScale + new_zstar_def = .false. min_thickness = min( CS%min_thickness, total_thickness/real(nz) ) z0_top = 0. @@ -82,8 +84,6 @@ subroutine build_zstar_column(CS, nz, depth, total_thickness, zInterface, & new_zstar_def = .true. endif - z_scale = 1.0 ; if (present(zScale)) z_scale = zScale - ! Position of free-surface (or the rigid top, for which eta ~ z0_top) eta = total_thickness - depth if (present(eta_orig)) eta = eta_orig From d6ad04725ddeaa4f36555df240ab82ad39c09868 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 2 Jan 2018 14:55:56 -0500 Subject: [PATCH 082/170] +Added GV to MOM_diag_mediator control structure Added a verticalGrid_type element to the control structure for MOM_diag_mediator and made use of this element in diag_remap_update, so that changes in the units for vertical thickness can be handled properly. All answers are bitwise identical, but there is a new required argument for mom_diag_mediator_init and mom_remap_update. --- src/core/MOM.F90 | 2 +- src/framework/MOM_diag_mediator.F90 | 7 ++- src/framework/MOM_diag_remap.F90 | 68 +++++++++++++++-------------- 3 files changed, 42 insertions(+), 35 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 41351b9b5e..68f0f6e1c3 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2081,7 +2081,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo diag => CS%diag ! Initialize the diag mediator. - call diag_mediator_init(G, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + call diag_mediator_init(G, GV, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) ! Initialize the diagnostics masks for native arrays. ! This step has to be done after call to MOM_initialize_state diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 6cc2674288..64f8bdd6c5 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -181,6 +181,7 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: S => null() type(EOS_type), pointer :: eqn_of_state => null() type(ocean_grid_type), pointer :: G => null() + type(verticalGrid_type), pointer :: GV => null() ! The volume cell measure (special diagnostic) manager id integer :: volume_cell_measure_dm_id = -1 @@ -2062,8 +2063,9 @@ end subroutine diag_mediator_infrastructure_init !> diag_mediator_init initializes the MOM diag_mediator and opens the available !! diagnostics file, if appropriate. -subroutine diag_mediator_init(G, nz, param_file, diag_cs, doc_file_dir) +subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) type(ocean_grid_type), target, intent(inout) :: G !< The ocean grid type. + type(verticalGrid_type), target, intent(in) :: GV !< The ocean vertical grid structure integer, intent(in) :: nz !< The number of layers in the model's native grid. type(param_file_type), intent(in) :: param_file !< Parameter file structure type(diag_ctrl), intent(inout) :: diag_cs !< A pointer to a type with many variables @@ -2130,6 +2132,7 @@ subroutine diag_mediator_init(G, nz, param_file, diag_cs, doc_file_dir) ! Keep pointers grid, h, T, S needed diagnostic remapping diag_cs%G => G + diag_cs%GV => GV diag_cs%h => null() diag_cs%T => null() diag_cs%S => null() @@ -2241,7 +2244,7 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), & - diag_cs%G, h_diag, T_diag, S_diag, & + diag_cs%G, diag_cs%GV, h_diag, T_diag, S_diag, & diag_cs%eqn_of_state) enddo diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index cea3a22c87..c0bdbf8959 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -29,7 +29,7 @@ module MOM_diag_remap use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : remapping_core_h use MOM_regridding, only : regridding_CS, initialize_regridding -use MOM_regridding, only : set_regrid_params, get_regrid_size, uniformResolution +use MOM_regridding, only : set_regrid_params, get_regrid_size use MOM_regridding, only : getCoordinateInterfaces use MOM_regridding, only : get_zlike_CS, get_sigma_CS, get_rho_CS use regrid_consts, only : coordinateMode @@ -220,15 +220,15 @@ function diag_remap_axes_configured(remap_cs) !! height or layer thicknesses changes. In the case of density-based !! coordinates then technically we should also regenerate the !! target grid whenever T/S change. -subroutine diag_remap_update(remap_cs, G, h, T, S, eqn_of_state) +subroutine diag_remap_update(remap_cs, G, GV, h, T, S, eqn_of_state) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), pointer :: G !< The ocean's grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(:, :, :), intent(in) :: h, T, S !< New thickness, T and S type(EOS_type), pointer, intent(in) :: eqn_of_state !< A pointer to the equation of state ! Local variables real, dimension(remap_cs%nz + 1) :: zInterfaces - real, dimension(remap_cs%nz) :: resolution real :: h_neglect, h_neglect_edge integer :: i, j, k, nz @@ -238,7 +238,12 @@ subroutine diag_remap_update(remap_cs, G, h, T, S, eqn_of_state) return endif - h_neglect = 1.0e-30 ; h_neglect_edge = 1.0e-10 !### Try using values from GV? + !### 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif nz = remap_cs%nz if (.not. remap_cs%initialized) then @@ -251,35 +256,34 @@ subroutine diag_remap_update(remap_cs, G, h, T, S, eqn_of_state) ! Calculate remapping thicknesses for different target grids based on ! nominal/target interface locations. This happens for every call on the ! assumption that h, T, S has changed. - do j=G%jsc-1, G%jec+1 - do i=G%isc-1, G%iec+1 - if (G%mask2dT(i,j)==0.) then - remap_cs%h(i,j,:) = 0. - cycle - endif + do j=G%jsc-1, G%jec+1 ; do i=G%isc-1, G%iec+1 + if (G%mask2dT(i,j)==0.) then + remap_cs%h(i,j,:) = 0. + cycle + endif - if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then - call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), nz, & - G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) - elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then - call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), nz, & - G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) - elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then - call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & - G%bathyT(i,j), h(i,j,:), T(i, j, :), S(i, j, :), & - eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) - elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then -! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & -! G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) - call MOM_error(FATAL,"diag_remap_update: SLIGHT coordinate not coded for diagnostics yet!") - elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then -! call build_hycom1_column(remap_cs%regrid_cs, nz, & -! G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) - call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") - endif - remap_cs%h(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) - enddo - enddo + if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then + call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), nz, & + G%bathyT(i,j)*GV%m_to_H, sum(h(i,j,:)), & + zInterfaces, zScale=GV%m_to_H) + elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then + call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), nz, & + GV%m_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) + elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then + call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & + G%bathyT(i,j), h(i,j,:), T(i, j, :), S(i, j, :), & + eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) + elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then +! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & +! G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) + call MOM_error(FATAL,"diag_remap_update: SLIGHT coordinate not coded for diagnostics yet!") + elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then +! call build_hycom1_column(remap_cs%regrid_cs, nz, & +! G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) + call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") + endif + remap_cs%h(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) + enddo ; enddo end subroutine diag_remap_update From 60999b141a2ec73a809f38da081f8254fc3c2136 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 2 Jan 2018 15:38:16 -0500 Subject: [PATCH 083/170] Avoid conversion when conversion_factor = 1 For efficiency, avoid code to do a multiplicative conversion of diagnostics when conversion_factor = 1. All answers are bitwise identical. --- src/framework/MOM_diag_mediator.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 64f8bdd6c5..ef22fa5581 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -818,7 +818,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) call MOM_error(FATAL,"post_data_2d_low: peculiar size in j-direction") endif - if (diag%conversion_factor/=0.) then + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) ) do j=jsv,jev ; do i=isv,iev if (field(i,j) == diag_cs%missing_value) then @@ -862,7 +862,8 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) weight=diag_cs%time_int) endif endif - if (diag%conversion_factor/=0.) deallocate( locfield ) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & + deallocate( locfield ) end subroutine post_data_2d_low @@ -1040,7 +1041,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) call MOM_error(FATAL,"post_data_3d_low: peculiar size in j-direction") endif - if (diag%conversion_factor/=0.) then + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then ks = lbound(field,3) ; ke = ubound(field,3) allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) ) do k=ks,ke ; do j=jsv,jev ; do i=isv,iev @@ -1091,7 +1092,8 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if (diag%fms_xyave_diag_id>0) then call post_xy_average(diag_cs, diag, locfield) endif - if (diag%conversion_factor/=0.) deallocate( locfield ) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & + deallocate( locfield ) end subroutine post_data_3d_low From 76bb70be83077a29f0b147e33969999594886bf8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 3 Jan 2018 09:37:40 -0500 Subject: [PATCH 084/170] +Corrected spatially averaged staggered diagnostics Corrected potential NaNs in spatially averaged staggered diagnostics with conversion factors, by translating the full (symmetric) range of variables that are used in the spatial averaging. Also use GV to set h_neglect when remapping non-extensive diagnostics, so that the tested diagnostics are now invariant to large power-of-2 changes in H_TO_M. All solutions are bitwise identical, although there is an additional verticalGrid_type arguemnt to diag_remap_do_remap, and some averaged diagnostics are changed. --- src/framework/MOM_diag_mediator.F90 | 23 ++++++++++++++--- src/framework/MOM_diag_remap.F90 | 40 +++++++++++++++++++---------- 2 files changed, 46 insertions(+), 17 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index ef22fa5581..c8c4deac44 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -943,7 +943,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) call diag_remap_do_remap(diag_cs%diag_remap_cs( & diag%axes%vertical_coordinate_number), & - diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & + diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, & diag%axes%mask3d, diag_cs%missing_value, field, remapped_field) if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then @@ -1006,8 +1006,9 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) real, dimension(:,:,:), pointer :: locfield => NULL() logical :: used ! The return value of send_data is not used for anything. + logical :: staggered_in_x, staggered_in_y logical :: is_stat - integer :: isv, iev, jsv, jev, ks, ke, i, j, k + integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1044,7 +1045,23 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then ks = lbound(field,3) ; ke = ubound(field,3) allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) ) - do k=ks,ke ; do j=jsv,jev ; do i=isv,iev + ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears not to be necessary. + isv_c = isv ; jsv_c = jsv + if (diag%fms_xyave_diag_id>0) then + staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point + staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point + ! When averaging a staggered field, edge points are always required. + if (staggered_in_x) isv_c = iev - (diag_cs%ie - diag_cs%is) - 1 + if (staggered_in_y) jsv_c = jev - (diag_cs%je - diag_cs%js) - 1 + if (isv_c < lbound(locfield,1)) call MOM_error(FATAL, & + "It is an error to average a staggered diagnostic field that does not "//& + "have i-direction space to represent the symmetric computational domain.") + if (jsv_c < lbound(locfield,2)) call MOM_error(FATAL, & + "It is an error to average a staggered diagnostic field that does not "//& + "have j-direction space to represent the symmetric computational domain.") + endif + + do k=ks,ke ; do j=jsv_c,jev ; do i=isv_c,iev if (field(i,j,k) == diag_cs%missing_value) then locfield(i,j,k) = diag_cs%missing_value else diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index c0bdbf8959..416b53cfb0 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -288,20 +288,22 @@ subroutine diag_remap_update(remap_cs, G, GV, h, T, S, eqn_of_state) end subroutine diag_remap_update !> Remap diagnostic field to alternative vertical grid. -subroutine diag_remap_do_remap(remap_cs, G, h, staggered_in_x, staggered_in_y, & +subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_y, & mask, missing_value, field, remapped_field) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses - logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points - logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points - real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped - real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field + real, intent(in) :: missing_value !< A missing_value to assign land/vanished points + real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped + real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate ! Local variables real, dimension(remap_cs%nz) :: h_dest real, dimension(size(h,3)) :: h_src + real :: h_neglect, h_neglect_edge integer :: nz_src, nz_dest integer :: i, j, k @@ -309,6 +311,13 @@ subroutine diag_remap_do_remap(remap_cs, G, h, staggered_in_x, staggered_in_y, & call assert(size(field, 3) == size(h, 3), & 'diag_remap_do_remap: Remap field and thickness z-axes do not match.') + !### 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 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + nz_src = size(field,3) nz_dest = remap_cs%nz remapped_field(:,:,:) = 0. @@ -323,7 +332,8 @@ subroutine diag_remap_do_remap(remap_cs, G, h, staggered_in_x, staggered_in_y, & h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & - nz_dest, h_dest(:), remapped_field(I,j,:)) + nz_dest, h_dest(:), remapped_field(I,j,:), & + h_neglect, h_neglect_edge) enddo enddo elseif (staggered_in_y .and. .not. staggered_in_x) then @@ -336,7 +346,8 @@ subroutine diag_remap_do_remap(remap_cs, G, h, staggered_in_x, staggered_in_y, & h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:) ) call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & - nz_dest, h_dest(:), remapped_field(i,J,:)) + nz_dest, h_dest(:), remapped_field(i,J,:), & + h_neglect, h_neglect_edge) enddo enddo elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -348,8 +359,9 @@ subroutine diag_remap_do_remap(remap_cs, G, h, staggered_in_x, staggered_in_y, & endif h_src(:) = h(i,j,:) h_dest(:) = remap_cs%h(i,j,:) - call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & - nz_dest, h_dest(:), remapped_field(i,j,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,j,:), & + nz_dest, h_dest(:), remapped_field(i,j,:), & + h_neglect, h_neglect_edge) enddo enddo else From 26abd28709b1efc8c9d134f5fe06031f8245a874 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Wed, 3 Jan 2018 10:21:02 -0500 Subject: [PATCH 085/170] Explicit naming of optional arguments - Optional argumnents to subroutine calls should be explicitly named - This branch is compatible with gitlab branch user/nnz/cas_geotherm_cobalt_updates https://gitlab.gfdl.noaa.gov/fms/ocean_shared/tree/user/nnz/cas_geotherm_cobalt_updates --- src/tracer/MOM_generic_tracer.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 3fe9eb25c6..b987f48c8c 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -614,7 +614,8 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, call generic_tracer_source(tv%T,tv%S,rho_dzt,dzt,Hml,G%isd,G%jsd,1,dt,& G%areaT,get_diag_time_end(CS%diag),& - optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, tv%internal_heat, fluxes%frunoff, sosga=sosga) + optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & + internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes ! usually in ALE mode From 76575e8c2c7bb625914fbb389f9f9f4a5313a16a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 4 Jan 2018 12:59:32 -0500 Subject: [PATCH 086/170] +Translate CMOR_longname and transmit via vardesc Added function cmor_long_std to convert CMOR long names into CMOR standard names. Also added a new cmor_longname element to vardesc type and corresponding optional arguments to the routines var_desc, query_vardesc and modify vardesc. All answers are bitwise identical, but a shared type has a new element, there are now optional arguments for three publicly visible subroutines, and there is a new function. --- src/framework/MOM_io.F90 | 52 +++++++++++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 14 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index f1ff2ca853..83a9a54829 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -45,7 +45,7 @@ module MOM_io public :: APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE public :: READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE public :: CENTER, CORNER, NORTH_FACE, EAST_FACE -public :: var_desc, modify_vardesc, query_vardesc +public :: var_desc, modify_vardesc, query_vardesc, cmor_long_std public :: get_axis_data !> Type for describing a variable, typically a tracer @@ -58,6 +58,7 @@ module MOM_io character(len=8) :: t_grid !< Time description: s, p, or 1 character(len=64) :: cmor_field_name !< CMOR name character(len=64) :: cmor_units !< CMOR physical dimensions of the variable + character(len=240) :: cmor_longname !< CMOR long name of the variable real :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive end type vardesc @@ -587,7 +588,7 @@ end function num_timelevels !! have default values that are empty strings or are appropriate for a 3-d !! tracer field at the tracer cell centers. function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, conversion, caller) result(vd) + cmor_field_name, cmor_units, cmor_longname, conversion, caller) result(vd) character(len=*), intent(in) :: name !< variable name character(len=*), optional, intent(in) :: units !< variable units character(len=*), optional, intent(in) :: longname !< variable long name @@ -596,6 +597,7 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name real , optional, intent(in) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive character(len=*), optional, intent(in) :: caller !< calling routine? @@ -612,20 +614,21 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, & vd%cmor_field_name = "" vd%cmor_units = "" + vd%cmor_longname = "" vd%conversion = 1.0 call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid, & cmor_field_name=cmor_field_name,cmor_units=cmor_units, & - conversion=conversion, caller=cllr) + cmor_longname=cmor_longname, conversion=conversion, caller=cllr) end function var_desc !> This routine modifies the named elements of a vardesc type. !! All arguments are optional, except the vardesc type to be modified. -subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid,& - cmor_field_name, cmor_units, conversion, caller) +subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & + cmor_field_name, cmor_units, cmor_longname, conversion, caller) type(vardesc), intent(inout) :: vd !< vardesc type that is modified character(len=*), optional, intent(in) :: name !< name of variable character(len=*), optional, intent(in) :: units !< units of variable @@ -635,6 +638,7 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid,& character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name real , optional, intent(in) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive character(len=*), optional, intent(in) :: caller !< calling routine? @@ -656,17 +660,34 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid,& if (present(t_grid)) call safe_string_copy(t_grid, vd%t_grid, & "vd%t_grid of "//trim(vd%name), cllr) - if (present(cmor_field_name)) call safe_string_copy(cmor_field_name, vd%cmor_field_name, & - "vd%cmor_field_name of "//trim(vd%name), cllr) - if (present(cmor_units)) call safe_string_copy(cmor_units, vd%cmor_units, & - "vd%cmor_units of "//trim(vd%name), cllr) + if (present(cmor_field_name)) call safe_string_copy(cmor_field_name, vd%cmor_field_name, & + "vd%cmor_field_name of "//trim(vd%name), cllr) + if (present(cmor_units)) call safe_string_copy(cmor_units, vd%cmor_units, & + "vd%cmor_units of "//trim(vd%name), cllr) + if (present(cmor_longname)) call safe_string_copy(cmor_longname, vd%cmor_longname, & + "vd%cmor_longname of "//trim(vd%name), cllr) end subroutine modify_vardesc +!> This function returns the CMOR standard name given a CMOR longname, based on +!! the standard pattern of character conversions. +function cmor_long_std(longname) result(std_name) + character(len=*), intent(in) :: longname !< The CMOR longname being converted + character(len=len(longname)) :: std_name !< The CMOR standard name generated from longname + + integer :: k + + std_name = lowercase(longname) + + do k=1, len_trim(std_name) + if (std_name(k:k) == ' ') std_name(k:k) = '_' + enddo + +end function cmor_long_std !> This routine queries vardesc subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, conversion, caller) + cmor_field_name, cmor_units, cmor_longname, conversion, caller) type(vardesc), intent(in) :: vd !< vardesc type that is queried character(len=*), optional, intent(out) :: name !< name of variable character(len=*), optional, intent(out) :: units !< units of variable @@ -676,6 +697,7 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(out) :: t_grid !< time description: s, p, or 1 character(len=*), optional, intent(out) :: cmor_field_name !< CMOR name character(len=*), optional, intent(out) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(out) :: cmor_longname !< CMOR long name real , optional, intent(out) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive character(len=*), optional, intent(in) :: caller !< calling routine? @@ -698,10 +720,12 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & if (present(t_grid)) call safe_string_copy(vd%t_grid, t_grid, & "vd%t_grid of "//trim(vd%name), cllr) - if (present(cmor_field_name)) call safe_string_copy(vd%cmor_field_name, cmor_field_name, & - "vd%cmor_field_name of "//trim(vd%name), cllr) - if (present(cmor_units)) call safe_string_copy(vd%cmor_units, cmor_units, & - "vd%cmor_units of "//trim(vd%name), cllr) + if (present(cmor_field_name)) call safe_string_copy(vd%cmor_field_name, cmor_field_name, & + "vd%cmor_field_name of "//trim(vd%name), cllr) + if (present(cmor_units)) call safe_string_copy(vd%cmor_units, cmor_units, & + "vd%cmor_units of "//trim(vd%name), cllr) + if (present(cmor_longname)) call safe_string_copy(vd%cmor_longname, cmor_longname, & + "vd%cmor_longname of "//trim(vd%name), cllr) end subroutine query_vardesc From 4b1c4537b4e7685580c89b8a219eed38c1b58c9a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 4 Jan 2018 13:01:17 -0500 Subject: [PATCH 087/170] +Improve tracer registry diagnostic capabilities Extend the capabilities of the diagnostics via the tracer registry to include separate rescaling of flux-convergence diagnostics, to properly deal with CMOR longnames, and to permit the pattern the long names to be selected via an optional argument when tracers are being registered. Also corrected a bug when using the tracer registry to write out the vertically integrated advective flux convergence that could lead to fatal segmentation faults, but this code had not previously been used so no answers change. All answers are bitwise identical, but there are new optional arguments to some subroutines. --- src/tracer/MOM_tracer_registry.F90 | 88 ++++++++++++++++++++---------- 1 file changed, 60 insertions(+), 28 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index fb7d865c09..b17828856b 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -14,7 +14,8 @@ module MOM_tracer_registry use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : vardesc, query_vardesc +use MOM_io, only : vardesc, query_vardesc, cmor_long_std +use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type use MOM_verticalGrid, only : verticalGrid_type @@ -62,9 +63,14 @@ module MOM_tracer_registry !! names of flux diagnostics. character(len=64) :: flux_longname = "" !< A word or phrase used construct the long !! names of flux diagnostics. - real :: flux_conversion = 1.0 !< A scaling factor used to convert the fluxes + real :: flux_scale= 1.0 !< A scaling factor used to convert the fluxes !! of this tracer to its desired units. character(len=48) :: flux_units = "" !< The units for fluxes of this variable. + character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. + real :: conv_scale = 1.0 !< A scaling factor used to convert the flux + !! convergence of this tracer to its desired units. + + integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. integer :: id_tr = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 @@ -88,7 +94,8 @@ module MOM_tracer_registry subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, ad_x, ad_y,& df_x, df_y, OBC_inflow, OBC_in_u, OBC_in_v, & ad_2d_x, ad_2d_y, df_2d_x, df_2d_y, advection_xy, registry_diags, & - flux_nameroot, flux_longname, flux_units, flux_conversion) + flux_nameroot, flux_longname, flux_units, flux_scale, & + convergence_units, convergence_scale, diag_form) type(hor_index_type), intent(in) :: HI !< horizontal index type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), target :: tr1 !< pointer to the tracer (concentration units) @@ -125,10 +132,14 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a !! names of flux diagnostics. character(len=*), optional, intent(in) :: flux_longname !< A word or phrase used construct the long !! names of flux diagnostics. - character(len=*), optional, intent(in) :: flux_units !< A scaling factor used to convert the fluxes - !! of this tracer to its desired units. - real, optional, intent(in) :: flux_conversion !< A scaling factor used to convert the fluxes + character(len=*), optional, intent(in) :: flux_units !< The units for the fluxes of this tracer. + real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes !! of this tracer to its desired units. + character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of this tracer. + real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux + !! convergence of this tracer to its desired units. + integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the character + !! string template to use in labeling diagnostics integer :: ntr type(tracer_type) :: temp character(len=72) :: longname ! The long name of a variable. @@ -169,8 +180,21 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a Reg%Tr(ntr)%flux_units = "" if (present(flux_units)) Reg%Tr(ntr)%flux_units = flux_units - Reg%Tr(ntr)%flux_conversion = 1.0 - if (present(flux_conversion)) Reg%Tr(ntr)%flux_conversion = flux_conversion + Reg%Tr(ntr)%flux_scale = 1.0 + if (present(flux_scale)) Reg%Tr(ntr)%flux_scale = flux_scale + + Reg%Tr(ntr)%conv_units = "" + if (present(convergence_units)) Reg%Tr(ntr)%conv_units = convergence_units + + Reg%Tr(ntr)%conv_scale = 1.0 + if (present(convergence_scale)) then + Reg%Tr(ntr)%conv_scale = convergence_scale + elseif (present(flux_scale)) then + Reg%Tr(ntr)%conv_scale = flux_scale + endif + + Reg%Tr(ntr)%diag_form = 1 + if (present(diag_form)) Reg%Tr(ntr)%diag_form = diag_form Reg%Tr(ntr)%t => tr1 @@ -202,7 +226,7 @@ subroutine lock_tracer_registry(Reg) type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry if (.not. associated(Reg)) call MOM_error(WARNING, & - "lock_tracer_registry called with an unassocaited registry.") + "lock_tracer_registry called with an unassociated registry.") Reg%locked = .True. @@ -306,22 +330,24 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) character(len=48) :: units ! The dimensions of the variable. character(len=48) :: flux_units ! The units for fluxes, either ! [units] m3 s-1 or [units] kg s-1. + character(len=48) :: conv_units ! The units for flux convergences, either + ! [units] m2 s-1 or [units] kg s-1. character(len=72) :: cmorname ! The CMOR name of that variable. + character(len=120) :: cmor_longname ! The CMOR long name of that variable. type(tracer_type), pointer :: Tr=>NULL() - integer :: m, form + integer :: m integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - form = 1 - if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_diagnostics: "// & "register_tracer must be called before add_tracer_diagnostics") do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) call query_vardesc(Tr%vd, name, units=units, longname=longname, & - cmor_field_name=cmorname, caller="register_tracer_diagnostics") + cmor_field_name=cmorname, cmor_longname=cmor_longname, & + caller="register_tracer_diagnostics") shortnm = Tr%flux_nameroot flux_longname = Tr%flux_longname @@ -329,14 +355,19 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) elseif (GV%Boussinesq) then ; flux_units = trim(units)//" m3 s-1" else ; flux_units = trim(units)//" kg s-1" ; endif + if (len_trim(Tr%conv_units) > 0) then ; conv_units = Tr%conv_units + elseif (GV%Boussinesq) then ; conv_units = trim(units)//" m s-1" + else ; conv_units = trim(units)//" kg m-2 s-1" ; endif + if (len_trim(cmorname) == 0) then Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & Time, trim(longname), trim(units)) else Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & - Time, trim(longname), trim(units), cmor_field_name=cmorname) + Time, trim(longname), trim(units), cmor_field_name=cmorname, & + cmor_standard_name=cmor_long_std(cmor_longname), cmor_long_name=cmor_longname) endif - if (form == 1) then + if (Tr%diag_form == 1) then Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & trim(flux_units)) @@ -352,16 +383,16 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) 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), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + flux_units, v_extensive=.true., conversion=Tr%flux_scale) Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, "Advective (by residual mean) Meridional Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + flux_units, v_extensive=.true., conversion=Tr%flux_scale) Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_diffx", & diag%axesCuL, Time, "Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + flux_units, v_extensive=.true., conversion=Tr%flux_scale) 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_conversion) + flux_units, v_extensive=.true., conversion=Tr%flux_scale) 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) @@ -371,19 +402,19 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & "Vertically Integrated Advective Zonal Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + flux_units, conversion=Tr%flux_scale) Tr%id_ady_2d = register_diag_field("ocean_model", trim(shortnm)//"_ady_2d", & diag%axesCv1, Time, & "Vertically Integrated Advective Meridional Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + flux_units, conversion=Tr%flux_scale) Tr%id_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffx_2d", & diag%axesCu1, Time, & "Vertically Integrated Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + flux_units, conversion=Tr%flux_scale) Tr%id_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffy_2d", & diag%axesCv1, Time, & "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + flux_units, conversion=Tr%flux_scale) 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) @@ -392,12 +423,13 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & - 'Horizontal convergence of residual mean advective fluxes of '//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_conversion) + 'Horizontal convergence of residual mean advective fluxes of '//& + trim(lowercase(flux_longname)), conv_units, v_extensive=.true., & + conversion=Tr%conv_scale) Tr%id_adv_xy_2d = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy_2d", & diag%axesT1, Time, & - 'Vertical sum of horizontal convergence of residual mean advective fluxes of'//trim(flux_longname), & - flux_units, conversion=Tr%flux_conversion) + 'Vertical sum of horizontal convergence of residual mean advective fluxes of '//& + trim(lowercase(flux_longname)), conv_units, conversion=Tr%conv_scale) if ((Tr%id_adv_xy > 0) .or. (Tr%id_adv_xy_2d > 0)) & call safe_alloc_ptr(Tr%advection_xy,isd,ied,jsd,jed,nz) @@ -437,7 +469,7 @@ subroutine post_tracer_diagnostics(Reg, diag, G, GV) do k=1,nz ; do j=js,je ; do i=is,ie work2d(i,j) = work2d(i,j) + Tr%advection_xy(i,j,k) enddo ; enddo ; enddo - call post_data(Tr%id_adv_xy_2d, Tr%advection_xy, diag) + call post_data(Tr%id_adv_xy_2d, work2d, diag) endif endif ; enddo end subroutine post_tracer_diagnostics From 8f4af3d9ef927dc4b99d2a44f32a1e0a3ca5c2c3 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 4 Jan 2018 12:07:52 -0800 Subject: [PATCH 088/170] Implement changes suggested by @Hallberg-NOAA On PR#670, @Hallberg-NOAA pointed out two aspects of the code that could be changed. As detailed in a reply to those comments, one of these was a non-answer changing bit of logic that could safely be removed and the other involved changing array syntax arithmetic to explicit loops. --- src/tracer/MOM_neutral_diffusion.F90 | 24 ++++++++++++++++-------- src/tracer/MOM_neutral_diffusion_aux.F90 | 2 +- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ab3b70c2b6..f63e1cd6c2 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -389,6 +389,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta real :: h_neglect, h_neglect_edge + real :: pa_to_H + + pa_to_H = 1. / GV%H_to_pa !### Try replacing both of these with GV%H_subroundoff if (GV%Boussinesq) then @@ -444,15 +447,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) else ! Discontinuous reconstruction do k = 1, G%ke if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) - if (CS%stable_cell(i,j,k)) & - call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & - CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, CS%EOS) + call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & + CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, CS%EOS) if (CS%ref_pres<0) then ref_pres(:) = CS%Pint(:,j,k+1) endif - if (CS%stable_cell(i,j,k)) & - call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & - CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS) + call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & + CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS) enddo endif enddo @@ -518,9 +519,16 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) endif enddo ; enddo + ! Continuous reconstructions calculate hEff as the difference between the pressures of the neutral surfaces which + ! need to be reconverted to thickness units. The discontinuous version calculates hEff from the fraction of the + ! nondimensional fraction of the layer occupied by the if (CS%continuous_reconstruction) then - CS%uhEff(:,:,:) = CS%uhEff(:,:,:) / GV%H_to_pa - CS%vhEff(:,:,:) = CS%vhEff(:,:,:) / GV%H_to_pa + do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec + if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H + enddo ; enddo ; enddo + do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec + if (G%mask2dCv(i,J) > 0.) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H + enddo ; enddo ; enddo endif if (CS%id_uhEff_2d>0) then diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 4d58545acc..7d10e8d575 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -161,7 +161,7 @@ real function calc_drho(T1, S1, dRdT1, dRdS1, T2, S2, dRdT2, dRdS2) end function calc_drho !> Calculate the difference in neutral density between a reference T, S, alpha, and beta -!! and a poiet on the polynomial reconstructions of T, S +!! at a point on the polynomial reconstructions of T, S subroutine drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, x0, & delta_rho, P_out, T_out, S_out, alpha_avg_out, beta_avg_out, delta_T_out, delta_S_out) type(ndiff_aux_CS_type), intent(in) :: CS !< Control structure with parameters for this module From a87c5efb02ba6a484f8e5e9ec832e7117660f9df Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 4 Jan 2018 14:48:11 -0500 Subject: [PATCH 089/170] +Use tracer registry for T & S diagnostics Use the tracer registry to handle the standard diagnostics related to temperature and salinity, including fluxes and flux convergence, eliminating the related code from MOM.F90. This leads to minor changes in several non-CMOR long names, and there are mathematically-equivalent differences in the order of arithmetic to some tracer convergence diagnostics. All solutions are bitwise identical. --- src/core/MOM.F90 | 291 ++++++++++------------------------------------- 1 file changed, 58 insertions(+), 233 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 68f0f6e1c3..dae8771f5d 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -279,16 +279,7 @@ module MOM vd_T, & !< vardesc array describing potential temperature vd_S !< vardesc array describing salinity - real, pointer, dimension(:,:,:) :: & !< diagnostic arrays of advective/diffusive tracer fluxes - T_adx => NULL(), T_ady => NULL(), T_diffx => NULL(), T_diffy => NULL(), & - S_adx => NULL(), S_ady => NULL(), S_diffx => NULL(), S_diffy => NULL() - - real, pointer, dimension(:,:) :: & !< diagnostic arrays of vertically integrated advective/diffusive fluxes - T_adx_2d => NULL(), T_ady_2d => NULL(), T_diffx_2d => NULL(), T_diffy_2d => NULL(), & - S_adx_2d => NULL(), S_ady_2d => NULL(), S_diffx_2d => NULL(), S_diffy_2d => NULL() - real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for advection tendencies and total tendencies - T_advection_xy => NULL(), S_advection_xy => NULL(), & T_prev => NULL(), S_prev => NULL(), & Th_prev => NULL(), Sh_prev => NULL() @@ -303,10 +294,8 @@ module MOM integer :: id_u = -1 integer :: id_v = -1 integer :: id_h = -1 - integer :: id_T = -1 - integer :: id_S = -1 - integer :: id_Tcon = -1 - integer :: id_Sabs = -1 + integer :: id_Tpot = -1 + integer :: id_Sprac = -1 ! 2-d surface and bottom fields integer :: id_zos = -1 @@ -333,32 +322,10 @@ module MOM integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - ! transport of temperature and salinity - integer :: id_Tadx = -1 - integer :: id_Tady = -1 - integer :: id_Tdiffx = -1 - integer :: id_Tdiffy = -1 - integer :: id_Sadx = -1 - integer :: id_Sady = -1 - integer :: id_Sdiffx = -1 - integer :: id_Sdiffy = -1 - integer :: id_Tadx_2d = -1 - integer :: id_Tady_2d = -1 - integer :: id_Tdiffx_2d = -1 - integer :: id_Tdiffy_2d = -1 - integer :: id_Sadx_2d = -1 - integer :: id_Sady_2d = -1 - integer :: id_Sdiffx_2d = -1 - integer :: id_Sdiffy_2d = -1 - ! tendencies for temp/heat and saln/salt - integer :: id_T_advection_xy = -1 - integer :: id_T_advection_xy_2d = -1 integer :: id_T_tendency = -1 integer :: id_Th_tendency = -1 integer :: id_Th_tendency_2d = -1 - integer :: id_S_advection_xy = -1 - integer :: id_S_advection_xy_2d = -1 integer :: id_S_tendency = -1 integer :: id_Sh_tendency = -1 integer :: id_Sh_tendency_2d = -1 @@ -1481,6 +1448,8 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. + real :: conv2watt, conv2salt, H_convert + character(len=48) :: thickness_units, flux_units, S_flux_units type(time_type) :: Start_time type(ocean_internal_state) :: MOM_internal_state @@ -1865,15 +1834,42 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ALLOC_(CS%T(isd:ied,jsd:jed,nz)) ; CS%T(:,:,:) = 0.0 ALLOC_(CS%S(isd:ied,jsd:jed,nz)) ; CS%S(:,:,:) = 0.0 CS%tv%T => CS%T ; CS%tv%S => CS%S - CS%vd_T = var_desc(name="T",units="degC",longname="Potential Temperature", & - cmor_field_name="thetao", & + if (CS%use_conT_absS) then + CS%vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & + cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & + conversion=CS%tv%C_p) + CS%vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & + cmor_field_name="so", cmor_longname="Sea Water Salinity", & + conversion=0.001) + else + CS%vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & + cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & conversion=CS%tv%C_p) - CS%vd_S = var_desc(name="S",units="psu",longname="Salinity",& - cmor_field_name="so", & + CS%vd_S = var_desc(name="salt",units="psu",longname="Salinity", & + cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) + endif if(CS%advect_TS) then - call register_tracer(CS%tv%T, CS%vd_T, param_file, dG%HI, GV, CS%tracer_Reg, CS%vd_T) - call register_tracer(CS%tv%S, CS%vd_S, param_file, dG%HI, GV, CS%tracer_Reg, CS%vd_S) + + S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? + conv2watt = GV%H_to_kg_m2 * CS%tv%C_p + if (GV%Boussinesq) then + conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? + H_convert = GV%H_to_m + else + conv2salt = GV%H_to_kg_m2 + H_convert = GV%H_to_kg_m2 + endif + call register_tracer(CS%tv%T, CS%vd_T, param_file, dG%HI, GV, CS%tracer_Reg, & + CS%vd_T, registry_diags=.true., flux_nameroot='T', & + flux_units='W m-2', flux_longname='Heat', & + flux_scale=conv2watt, convergence_units='W m-2', & + convergence_scale=conv2watt, diag_form=2) + call register_tracer(CS%tv%S, CS%vd_S, param_file, dG%HI, GV, CS%tracer_Reg, & + CS%vd_S, registry_diags=.true., flux_nameroot='S', & + flux_units=S_flux_units, flux_longname='Salt', & + flux_scale=conv2salt, convergence_units='kg m-2 s-1', & + convergence_scale=0.001*GV%H_to_kg_m2, diag_form=2) endif if (associated(CS%OBC)) & call register_temp_salt_segments(GV, CS%OBC, CS%tv, CS%vd_T, CS%vd_S, param_file) @@ -2199,14 +2195,6 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! If need a diagnostic field, then would have been allocated in register_diags. if (CS%use_temperature) then - if(CS%advect_TS) then - call add_tracer_diagnostics("T", CS%tracer_Reg, CS%T_adx, CS%T_ady, & - CS%T_diffx, CS%T_diffy, CS%T_adx_2d, CS%T_ady_2d, & - CS%T_diffx_2d, CS%T_diffy_2d, CS%T_advection_xy) - call add_tracer_diagnostics("S", CS%tracer_Reg, CS%S_adx, CS%S_ady, & - CS%S_diffx, CS%S_diffy, CS%S_adx_2d, CS%S_ady_2d, & - CS%S_diffx_2d, CS%S_diffy_2d, CS%S_advection_xy) - endif call register_Z_tracer(CS%tv%T, "temp", "Potential Temperature", "degC", Time, & G, CS%diag_to_Z_CSp, cmor_field_name="thetao", & cmor_standard_name="sea_water_potential_temperature", & @@ -2349,7 +2337,7 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) - S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? + S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg s-1"? conv2watt = GV%H_to_kg_m2 * C_p if (GV%Boussinesq) then conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? @@ -2396,15 +2384,6 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) 'Sea Surface Speed', 'm s-1', CS%missing) if (CS%use_temperature) then - CS%id_T = register_diag_field('ocean_model', 'temp', diag%axesTL, Time, & - 'Potential Temperature', 'degC', & - cmor_field_name="thetao", & - cmor_standard_name="sea_water_potential_temperature", & - cmor_long_name ="Sea Water Potential Temperature") - CS%id_S = register_diag_field('ocean_model', 'salt', diag%axesTL, Time, & - long_name='Salinity', units='psu', cmor_field_name='so', & - cmor_long_name='Sea Water Salinity', & - cmor_standard_name='sea_water_salinity') CS%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & long_name='Sea Water Potential Temperature at Sea Floor', & standard_name='sea_water_potential_temperature_at_sea_floor', units='degC') @@ -2428,10 +2407,10 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) cmor_long_name='Square of Sea Surface Salinity ', & cmor_standard_name='square_of_sea_surface_salinity') if (CS%use_conT_absS) then - CS%id_Tcon = register_diag_field('ocean_model', 'contemp', diag%axesTL, Time, & - 'Conservative Temperature', 'Celsius') - CS%id_Sabs = register_diag_field('ocean_model', 'abssalt', diag%axesTL, Time, & - long_name='Absolute Salinity', units='g kg-1') + CS%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, Time, & + 'Potential Temperature', 'degC') + CS%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, Time, & + 'Salinity', 'psu') CS%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & 'Sea Surface Conservative Temperature', 'Celsius', CS%missing) CS%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & @@ -2453,78 +2432,6 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) CS%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') - - ! lateral heat advective and diffusive fluxes - CS%id_Tadx = register_diag_field('ocean_model', 'T_adx', diag%axesCuL, Time, & - 'Advective (by residual mean) Zonal Flux of Heat', 'W m-2', & - v_extensive = .true., conversion = conv2watt) - CS%id_Tady = register_diag_field('ocean_model', 'T_ady', diag%axesCvL, Time, & - 'Advective (by residual mean) Meridional Flux of Heat', 'W m-2', & - v_extensive = .true., conversion = conv2watt) - CS%id_Tdiffx = register_diag_field('ocean_model', 'T_diffx', diag%axesCuL, Time, & - 'Diffusive Zonal Flux of Heat', 'W m-2', & - v_extensive = .true., conversion = conv2watt) - CS%id_Tdiffy = register_diag_field('ocean_model', 'T_diffy', diag%axesCvL, Time, & - 'Diffusive Meridional Flux of Heat', 'W m-2', & - v_extensive = .true., conversion = conv2watt) - if (CS%id_Tadx > 0) call safe_alloc_ptr(CS%T_adx,IsdB,IedB,jsd,jed,nz) - if (CS%id_Tady > 0) call safe_alloc_ptr(CS%T_ady,isd,ied,JsdB,JedB,nz) - if (CS%id_Tdiffx > 0) call safe_alloc_ptr(CS%T_diffx,IsdB,IedB,jsd,jed,nz) - if (CS%id_Tdiffy > 0) call safe_alloc_ptr(CS%T_diffy,isd,ied,JsdB,JedB,nz) - - - ! lateral salt advective and diffusive fluxes - CS%id_Sadx = register_diag_field('ocean_model', 'S_adx', diag%axesCuL, Time, & - 'Advective (by residual mean) Zonal Flux of Salt', S_flux_units, & - v_extensive = .true., conversion = conv2salt) - CS%id_Sady = register_diag_field('ocean_model', 'S_ady', diag%axesCvL, Time, & - 'Advective (by residual mean) Meridional Flux of Salt', S_flux_units, & - v_extensive = .true., conversion = conv2salt) - CS%id_Sdiffx = register_diag_field('ocean_model', 'S_diffx', diag%axesCuL, Time, & - 'Diffusive Zonal Flux of Salt', S_flux_units, & - v_extensive = .true., conversion = conv2salt) - CS%id_Sdiffy = register_diag_field('ocean_model', 'S_diffy', diag%axesCvL, Time, & - 'Diffusive Meridional Flux of Salt', S_flux_units, & - v_extensive = .true., conversion = conv2salt) - if (CS%id_Sadx > 0) call safe_alloc_ptr(CS%S_adx,IsdB,IedB,jsd,jed,nz) - if (CS%id_Sady > 0) call safe_alloc_ptr(CS%S_ady,isd,ied,JsdB,JedB,nz) - if (CS%id_Sdiffx > 0) call safe_alloc_ptr(CS%S_diffx,IsdB,IedB,jsd,jed,nz) - if (CS%id_Sdiffy > 0) call safe_alloc_ptr(CS%S_diffy,isd,ied,JsdB,JedB,nz) - - - ! vertically integrated lateral heat advective and diffusive fluxes - CS%id_Tadx_2d = register_diag_field('ocean_model', 'T_adx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Advective Zonal Flux of Heat', 'W m-2', & - conversion = conv2watt) - CS%id_Tady_2d = register_diag_field('ocean_model', 'T_ady_2d', diag%axesCv1, Time, & - 'Vertically Integrated Advective Meridional Flux of Heat', 'W m-2', & - conversion = conv2watt) - CS%id_Tdiffx_2d = register_diag_field('ocean_model', 'T_diffx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Diffusive Zonal Flux of Heat', 'W m-2', & - conversion = conv2watt) - CS%id_Tdiffy_2d = register_diag_field('ocean_model', 'T_diffy_2d', diag%axesCv1, Time, & - 'Vertically Integrated Diffusive Meridional Flux of Heat', 'W m-2', & - conversion = conv2watt) - if (CS%id_Tadx_2d > 0) call safe_alloc_ptr(CS%T_adx_2d,IsdB,IedB,jsd,jed) - if (CS%id_Tady_2d > 0) call safe_alloc_ptr(CS%T_ady_2d,isd,ied,JsdB,JedB) - if (CS%id_Tdiffx_2d > 0) call safe_alloc_ptr(CS%T_diffx_2d,IsdB,IedB,jsd,jed) - if (CS%id_Tdiffy_2d > 0) call safe_alloc_ptr(CS%T_diffy_2d,isd,ied,JsdB,JedB) - - ! vertically integrated lateral salt advective and diffusive fluxes - CS%id_Sadx_2d = register_diag_field('ocean_model', 'S_adx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Advective Zonal Flux of Salt', S_flux_units, conversion = conv2salt) - CS%id_Sady_2d = register_diag_field('ocean_model', 'S_ady_2d', diag%axesCv1, Time, & - 'Vertically Integrated Advective Meridional Flux of Salt', S_flux_units, conversion = conv2salt) - CS%id_Sdiffx_2d = register_diag_field('ocean_model', 'S_diffx_2d', diag%axesCu1, Time, & - 'Vertically Integrated Diffusive Zonal Flux of Salt', S_flux_units, conversion = conv2salt) - CS%id_Sdiffy_2d = register_diag_field('ocean_model', 'S_diffy_2d', diag%axesCv1, Time, & - 'Vertically Integrated Diffusive Meridional Flux of Salt', S_flux_units, conversion = conv2salt) - if (CS%id_Sadx_2d > 0) call safe_alloc_ptr(CS%S_adx_2d,IsdB,IedB,jsd,jed) - if (CS%id_Sady_2d > 0) call safe_alloc_ptr(CS%S_ady_2d,isd,ied,JsdB,JedB) - if (CS%id_Sdiffx_2d > 0) call safe_alloc_ptr(CS%S_diffx_2d,IsdB,IedB,jsd,jed) - if (CS%id_Sdiffy_2d > 0) call safe_alloc_ptr(CS%S_diffy_2d,isd,ied,JsdB,JedB) - - if (CS%debug_truncations) then call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) @@ -2572,17 +2479,6 @@ subroutine register_diags_TS_tendency(Time, G, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! heat tendencies from lateral advection - CS%id_T_advection_xy = register_diag_field('ocean_model', 'T_advection_xy', diag%axesTL, Time, & - 'Horizontal convergence of residual mean heat advective fluxes', 'W m-2',v_extensive=.true.) - CS%id_T_advection_xy_2d = register_diag_field('ocean_model', 'T_advection_xy_2d', diag%axesT1, Time,& - 'Vertical sum of horizontal convergence of residual mean heat advective fluxes', 'W m-2') - if (CS%id_T_advection_xy > 0 .or. CS%id_T_advection_xy_2d > 0) then - call safe_alloc_ptr(CS%T_advection_xy,isd,ied,jsd,jed,nz) - CS%tendency_diagnostics = .true. - endif - ! net temperature and heat tendencies CS%id_T_tendency = register_diag_field('ocean_model', 'T_tendency', diag%axesTL, Time, & 'Net time tendency for temperature', 'degC s-1') @@ -2612,17 +2508,6 @@ subroutine register_diags_TS_tendency(Time, G, CS) enddo ; enddo ; enddo endif - - ! salt tendencies from lateral advection - CS%id_S_advection_xy = register_diag_field('ocean_model', 'S_advection_xy', diag%axesTL, Time, & - 'Horizontal convergence of residual mean salt advective fluxes', 'kg m-2 s-1', v_extensive=.true.) - CS%id_S_advection_xy_2d = register_diag_field('ocean_model', 'S_advection_xy_2d', diag%axesT1, Time,& - 'Vertical sum of horizontal convergence of residual mean salt advective fluxes', 'kg m-2 s-1') - if (CS%id_S_advection_xy > 0 .or. CS%id_S_advection_xy_2d > 0) then - call safe_alloc_ptr(CS%S_advection_xy,isd,ied,jsd,jed,nz) - CS%tendency_diagnostics = .true. - endif - ! net salinity and salt tendencies CS%id_S_tendency = register_diag_field('ocean_model', 'S_tendency', diag%axesTL, Time, & 'Net time tendency for salinity', 'psu s-1') @@ -2822,49 +2707,25 @@ subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.NOT. CS%use_conT_absS) then - !Internal T&S variables are assumed to be potential&practical - if (CS%id_T > 0) call post_data(CS%id_T, tv%T, diag) - if (CS%id_S > 0) call post_data(CS%id_S, tv%S, diag) - + ! Internal T&S variables are potential temperature & practical salinity if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,G%ke), diag, mask=G%mask2dT) if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,G%ke), diag, mask=G%mask2dT) else - !Internal T&S variables are assumed to be conservative&absolute - if (CS%id_Tcon > 0) call post_data(CS%id_Tcon, tv%T, diag) - if (CS%id_Sabs > 0) call post_data(CS%id_Sabs, tv%S, diag) - !Using TEOS-10 function calls convert T&S diagnostics - !from conservative temp to potential temp and - !from absolute salinity to practical salinity - do k=1,nz ; do j=js,je ; do i=is,ie - pracSal(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) - potTemp(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) - enddo; enddo ; enddo - if (CS%id_T > 0) call post_data(CS%id_T, potTemp, diag) - if (CS%id_S > 0) call post_data(CS%id_S, pracSal, diag) - if (CS%id_tob > 0) call post_data(CS%id_tob, potTemp(:,:,G%ke), diag, mask=G%mask2dT) - if (CS%id_sob > 0) call post_data(CS%id_sob, pracSal(:,:,G%ke), diag, mask=G%mask2dT) + ! Internal T&S variables are conservative temperature & absolute salinity, + ! so they need to converted to potential temperature and practical salinity + ! for some diagnostics using TEOS-10 function calls. + if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0) .or. (CS%id_Sprac > 0) .or. (CS%id_sob > 0)) then + do k=1,nz ; do j=js,je ; do i=is,ie + pracSal(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) + potTemp(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) + enddo; enddo ; enddo + if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, potTemp, diag) + if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, pracSal, diag) + if (CS%id_tob > 0) call post_data(CS%id_tob, potTemp(:,:,G%ke), diag, mask=G%mask2dT) + if (CS%id_sob > 0) call post_data(CS%id_sob, pracSal(:,:,G%ke), diag, mask=G%mask2dT) + endif endif - if (CS%id_Tadx > 0) call post_data(CS%id_Tadx, CS%T_adx, diag) - if (CS%id_Tady > 0) call post_data(CS%id_Tady, CS%T_ady, diag) - if (CS%id_Tdiffx > 0) call post_data(CS%id_Tdiffx, CS%T_diffx, diag) - if (CS%id_Tdiffy > 0) call post_data(CS%id_Tdiffy, CS%T_diffy, diag) - - if (CS%id_Sadx > 0) call post_data(CS%id_Sadx, CS%S_adx, diag) - if (CS%id_Sady > 0) call post_data(CS%id_Sady, CS%S_ady, diag) - if (CS%id_Sdiffx > 0) call post_data(CS%id_Sdiffx, CS%S_diffx, diag) - if (CS%id_Sdiffy > 0) call post_data(CS%id_Sdiffy, CS%S_diffy, diag) - - if (CS%id_Tadx_2d > 0) call post_data(CS%id_Tadx_2d, CS%T_adx_2d, diag) - if (CS%id_Tady_2d > 0) call post_data(CS%id_Tady_2d, CS%T_ady_2d, diag) - if (CS%id_Tdiffx_2d > 0) call post_data(CS%id_Tdiffx_2d, CS%T_diffx_2d, diag) - if (CS%id_Tdiffy_2d > 0) call post_data(CS%id_Tdiffy_2d, CS%T_diffy_2d, diag) - - if (CS%id_Sadx_2d > 0) call post_data(CS%id_Sadx_2d, CS%S_adx_2d, diag) - if (CS%id_Sady_2d > 0) call post_data(CS%id_Sady_2d, CS%S_ady_2d, diag) - if (CS%id_Sdiffx_2d > 0) call post_data(CS%id_Sdiffx_2d, CS%S_diffx_2d, diag) - if (CS%id_Sdiffy_2d > 0) call post_data(CS%id_Sdiffy_2d, CS%S_diffy_2d, diag) - if(.not. CS%tendency_diagnostics) return Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval @@ -2872,42 +2733,6 @@ subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) work3d(:,:,:) = 0.0 work2d(:,:) = 0.0 - ! Diagnose tendency of heat from convergence of lateral advective, - ! fluxes, where advective transport arises from residual mean velocity. - if (CS%id_T_advection_xy > 0 .or. CS%id_T_advection_xy_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = CS%T_advection_xy(i,j,k) * GV%H_to_kg_m2 * tv%C_p - enddo ; enddo ; enddo - if (CS%id_T_advection_xy > 0) call post_data(CS%id_T_advection_xy, work3d, diag) - if (CS%id_T_advection_xy_2d > 0) then - do j=js,je ; do i=is,ie - work2d(i,j) = 0.0 - do k=1,nz - work2d(i,j) = work2d(i,j) + work3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_T_advection_xy_2d, work2d, diag) - endif - endif - - ! Diagnose tendency of salt from convergence of lateral advective - ! fluxes, where advective transport arises from residual mean velocity. - if (CS%id_S_advection_xy > 0 .or. CS%id_S_advection_xy_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = CS%S_advection_xy(i,j,k) * GV%H_to_kg_m2 * ppt2mks - enddo ; enddo ; enddo - if (CS%id_S_advection_xy > 0) call post_data(CS%id_S_advection_xy, work3d, diag) - if (CS%id_S_advection_xy_2d > 0) then - do j=js,je ; do i=is,ie - work2d(i,j) = 0.0 - do k=1,nz - work2d(i,j) = work2d(i,j) + work3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_S_advection_xy_2d, work2d, diag) - endif - endif - ! diagnose net tendency for temperature over a time step and update T_prev if (CS%id_T_tendency > 0) then do k=1,nz ; do j=js,je ; do i=is,ie @@ -2929,7 +2754,7 @@ subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) ! diagnose net tendency for heat content of a grid cell over a time step and update Th_prev if (CS%id_Th_tendency > 0 .or. CS%id_Th_tendency_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = (tv%T(i,j,k)*CS%h(i,j,k) - CS%Th_prev(i,j,k)) * Idt * GV%H_to_kg_m2 * tv%C_p + work3d(i,j,k) = (tv%T(i,j,k)*CS%h(i,j,k) - CS%Th_prev(i,j,k)) * Idt * (GV%H_to_kg_m2 * tv%C_p) CS%Th_prev(i,j,k) = tv%T(i,j,k)*CS%h(i,j,k) enddo ; enddo ; enddo if (CS%id_Th_tendency > 0) call post_data(CS%id_Th_tendency, work3d, diag) @@ -2947,7 +2772,7 @@ subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) ! diagnose net tendency for salt content of a grid cell over a time step and update Sh_prev if (CS%id_Sh_tendency > 0 .or. CS%id_Sh_tendency_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = (tv%S(i,j,k)*CS%h(i,j,k) - CS%Sh_prev(i,j,k)) * Idt * GV%H_to_kg_m2 * ppt2mks + work3d(i,j,k) = (tv%S(i,j,k)*CS%h(i,j,k) - CS%Sh_prev(i,j,k)) * Idt * (GV%H_to_kg_m2 * ppt2mks) CS%Sh_prev(i,j,k) = tv%S(i,j,k)*CS%h(i,j,k) enddo ; enddo ; enddo if (CS%id_Sh_tendency > 0) call post_data(CS%id_Sh_tendency, work3d, diag) From fb30bb58b05f7c383fd8013fa0abdef4de134339 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 4 Jan 2018 17:09:28 -0500 Subject: [PATCH 090/170] +Add tracer tendency diagnostic to tracer_registry Added the tracer tendency diagnostic to the diagnostics provided by the tracer registry. All answers and diagnostics are bitwise identical, but a mandatory time-interval argument was added to post_tracer_diagnostics and there are some small changes to the long names for the native temperature and salinity diagnostics. --- src/core/MOM.F90 | 43 ++---------------------------- src/tracer/MOM_tracer_registry.F90 | 37 ++++++++++++++++++++++--- 2 files changed, 35 insertions(+), 45 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index dae8771f5d..2096d65f8e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -280,7 +280,6 @@ module MOM vd_S !< vardesc array describing salinity real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for advection tendencies and total tendencies - T_prev => NULL(), S_prev => NULL(), & Th_prev => NULL(), Sh_prev => NULL() real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for variance decay through ALE @@ -300,7 +299,7 @@ module MOM ! 2-d surface and bottom fields integer :: id_zos = -1 integer :: id_zossq = -1 - integer :: id_volo = -1 + integer :: id_volo = -1; integer :: id_ssh = -1 integer :: id_ssh_ga = -1 integer :: id_sst = -1 @@ -323,10 +322,8 @@ module MOM integer :: id_intern_heat = -1 ! tendencies for temp/heat and saln/salt - integer :: id_T_tendency = -1 integer :: id_Th_tendency = -1 integer :: id_Th_tendency_2d = -1 - integer :: id_S_tendency = -1 integer :: id_Sh_tendency = -1 integer :: id_Sh_tendency_2d = -1 @@ -902,7 +899,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call enable_averaging(CS%t_dyn_rel_diag, Time_local, CS%diag) call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, fluxes, CS%t_dyn_rel_diag, G, GV, CS%diagnostics_CSp) - call post_tracer_diagnostics(CS%Tracer_reg, CS%diag, G, GV) + call post_tracer_diagnostics(CS%Tracer_reg, CS%diag, G, GV, CS%t_dyn_rel_diag) call post_TS_diagnostics(CS, G, GV, CS%tv, CS%diag, CS%t_dyn_rel_diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) @@ -2480,8 +2477,6 @@ subroutine register_diags_TS_tendency(Time, G, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ! net temperature and heat tendencies - CS%id_T_tendency = register_diag_field('ocean_model', 'T_tendency', diag%axesTL, Time, & - 'Net time tendency for temperature', 'degC s-1') CS%id_Th_tendency = register_diag_field('ocean_model', 'Th_tendency', diag%axesTL, Time, & 'Net time tendency for heat', 'W m-2', & cmor_field_name="opottemptend", & @@ -2493,13 +2488,6 @@ subroutine register_diags_TS_tendency(Time, G, CS) cmor_field_name="opottemptend_2d", & cmor_standard_name="tendency_of_sea_water_potential_temperature_expressed_as_heat_content_vertical_sum",& cmor_long_name ="Tendency of Sea Water Potential Temperature Expressed as Heat Content Vertical Sum") - if (CS%id_T_tendency > 0) then - CS%tendency_diagnostics = .true. - call safe_alloc_ptr(CS%T_prev,isd,ied,jsd,jed,nz) - do k=1,nz ; do j=js,je ; do i=is,ie - CS%T_prev(i,j,k) = CS%tv%T(i,j,k) - enddo ; enddo ; enddo - endif if (CS%id_Th_tendency > 0 .or. CS%id_Th_tendency_2d > 0) then CS%tendency_diagnostics = .true. call safe_alloc_ptr(CS%Th_prev,isd,ied,jsd,jed,nz) @@ -2509,8 +2497,6 @@ subroutine register_diags_TS_tendency(Time, G, CS) endif ! net salinity and salt tendencies - CS%id_S_tendency = register_diag_field('ocean_model', 'S_tendency', diag%axesTL, Time, & - 'Net time tendency for salinity', 'psu s-1') CS%id_Sh_tendency = register_diag_field('ocean_model', 'Sh_tendency', diag%axesTL, Time,& 'Net time tendency for salt', 'kg m-2 s-1', & cmor_field_name="osalttend", & @@ -2522,13 +2508,6 @@ subroutine register_diags_TS_tendency(Time, G, CS) cmor_field_name="osalttend_2d", & cmor_standard_name="tendency_of_sea_water_salinity_expressed_as_salt_content_vertical_sum",& cmor_long_name ="Tendency of Sea Water Salinity Expressed as Salt Content Vertical Sum") - if (CS%id_S_tendency > 0) then - CS%tendency_diagnostics = .true. - call safe_alloc_ptr(CS%S_prev,isd,ied,jsd,jed,nz) - do k=1,nz ; do j=js,je ; do i=is,ie - CS%S_prev(i,j,k) = CS%tv%S(i,j,k) - enddo ; enddo ; enddo - endif if (CS%id_Sh_tendency > 0 .or. CS%id_Sh_tendency_2d > 0) then CS%tendency_diagnostics = .true. call safe_alloc_ptr(CS%Sh_prev,isd,ied,jsd,jed,nz) @@ -2733,24 +2712,6 @@ subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) work3d(:,:,:) = 0.0 work2d(:,:) = 0.0 - ! diagnose net tendency for temperature over a time step and update T_prev - if (CS%id_T_tendency > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = (tv%T(i,j,k) - CS%T_prev(i,j,k))*Idt - CS%T_prev(i,j,k) = tv%T(i,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_T_tendency, work3d, diag) - endif - - ! diagnose net tendency for salinity over a time step and update S_prev - if (CS%id_S_tendency > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = (tv%S(i,j,k) - CS%S_prev(i,j,k))*Idt - CS%S_prev(i,j,k) = tv%S(i,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_S_tendency, work3d, diag) - endif - ! diagnose net tendency for heat content of a grid cell over a time step and update Th_prev if (CS%id_Th_tendency > 0 .or. CS%id_Th_tendency_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index b17828856b..93b46bf699 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -54,6 +54,8 @@ module MOM_tracer_registry !! in units of (conc * m3/s or conc * kg/s) real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes + real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous + !! timestep used for diagnostics character(len=32) :: name !< tracer name used for diagnostics and error messages type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer @@ -75,6 +77,7 @@ module MOM_tracer_registry integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_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_tendency = -1 end type tracer_type !> Type to carry basic tracer information @@ -335,9 +338,10 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) character(len=72) :: cmorname ! The CMOR name of that variable. character(len=120) :: cmor_longname ! The CMOR long name of that variable. type(tracer_type), pointer :: Tr=>NULL() - integer :: m - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + integer :: i, j, k, is, ie, js, je, nz, m + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_diagnostics: "// & @@ -433,6 +437,17 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) if ((Tr%id_adv_xy > 0) .or. (Tr%id_adv_xy_2d > 0)) & call safe_alloc_ptr(Tr%advection_xy,isd,ied,jsd,jed,nz) + Tr%id_tendency = register_diag_field('ocean_model', trim(shortnm)//'_tendency', & + diag%axesTL, Time, & + 'Net time tendency for '//trim(lowercase(longname)), trim(units)//' s-1') + + if (Tr%id_tendency > 0) then + call safe_alloc_ptr(Tr%t_prev,isd,ied,jsd,jed,nz) + do k=1,nz ; do j=js,je ; do i=is,ie + Tr%t_prev(i,j,k) = Tr%t(i,j,k) + enddo ; enddo ; enddo + endif + ! call register_Z_tracer(Tr%t, name, longname, units, & ! Time, G, diag_to_Z_CSp) endif ; enddo @@ -441,17 +456,22 @@ end subroutine register_tracer_diagnostics !> post_tracer_diagnostics does post_data calls for any diagnostics that are !! being handled via the tracer registry. -subroutine post_tracer_diagnostics(Reg, diag, G, GV) +subroutine post_tracer_diagnostics(Reg, diag, G, GV, dt) type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output 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, intent(in) :: dt !< total time step for tracer updates + real :: work3d(SZI_(G),SZJ_(G),SZK_(G)) real :: work2d(SZI_(G),SZJ_(G)) + real :: Idt type(tracer_type), pointer :: Tr=>NULL() 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 + Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) if (Tr%id_tr > 0) call post_data(Tr%id_tr, Tr%t, diag) @@ -471,7 +491,16 @@ subroutine post_tracer_diagnostics(Reg, diag, G, GV) enddo ; enddo ; enddo call post_data(Tr%id_adv_xy_2d, work2d, diag) endif + if (Tr%id_tendency > 0) then + work3d(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work3d(i,j,k) = (Tr%t(i,j,k) - Tr%t_prev(i,j,k))*Idt + tr%t_prev(i,j,k) = Tr%t(i,j,k) + enddo ; enddo ; enddo + call post_data(Tr%id_tendency, work3d, diag) + endif endif ; enddo + end subroutine post_tracer_diagnostics !> This subroutine writes out chksums for tracers. From cc66c20e5271ebb154d228bd3108b271a475fdf1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 4 Jan 2018 19:11:20 -0500 Subject: [PATCH 091/170] +Add integrated tracer tendency to tracer_registry Added the layer integrated tracer tendency diagnostics to the diagnostics provided by the tracer registry. All answers and diagnostics are bitwise identical, but the subroutine register_diags_TS_tendency has been eliminated, a mandatory layer thickness arguments were added to register_tracer_diagnostics and post_tracer_diagnostics and a new optional argument, cmor_tendname, has been added to register_tracer. All answers and diagnostics are bitwise identical, but the order of entries in the available_diags files change. --- src/core/MOM.F90 | 119 +---------------------------- src/tracer/MOM_tracer_registry.F90 | 78 ++++++++++++++++--- 2 files changed, 72 insertions(+), 125 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2096d65f8e..f6da1b928f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -279,9 +279,6 @@ module MOM vd_T, & !< vardesc array describing potential temperature vd_S !< vardesc array describing salinity - real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for advection tendencies and total tendencies - Th_prev => NULL(), Sh_prev => NULL() - real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for variance decay through ALE T_squared => NULL(), S_squared => NULL() @@ -321,12 +318,6 @@ module MOM integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - ! tendencies for temp/heat and saln/salt - integer :: id_Th_tendency = -1 - integer :: id_Th_tendency_2d = -1 - integer :: id_Sh_tendency = -1 - integer :: id_Sh_tendency_2d = -1 - ! variance decay for temp and heat integer :: id_T_vardec = -1 integer :: id_S_vardec = -1 @@ -899,7 +890,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call enable_averaging(CS%t_dyn_rel_diag, Time_local, CS%diag) call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, fluxes, CS%t_dyn_rel_diag, G, GV, CS%diagnostics_CSp) - call post_tracer_diagnostics(CS%Tracer_reg, CS%diag, G, GV, CS%t_dyn_rel_diag) + call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag, G, GV, CS%t_dyn_rel_diag) call post_TS_diagnostics(CS, G, GV, CS%tv, CS%diag, CS%t_dyn_rel_diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) @@ -1861,12 +1852,12 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo CS%vd_T, registry_diags=.true., flux_nameroot='T', & flux_units='W m-2', flux_longname='Heat', & flux_scale=conv2watt, convergence_units='W m-2', & - convergence_scale=conv2watt, diag_form=2) + convergence_scale=conv2watt, CMOR_tendname="opottemptend", diag_form=2) call register_tracer(CS%tv%S, CS%vd_S, param_file, dG%HI, GV, CS%tracer_Reg, & CS%vd_S, registry_diags=.true., flux_nameroot='S', & flux_units=S_flux_units, flux_longname='Salt', & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & - convergence_scale=0.001*GV%H_to_kg_m2, diag_form=2) + convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendname="osalttend", diag_form=2) endif if (associated(CS%OBC)) & call register_temp_salt_segments(GV, CS%OBC, CS%tv, CS%vd_T, CS%vd_S, param_file) @@ -2184,8 +2175,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! now register some diagnostics since tracer registry is locked call register_diags(Time, G, GV, CS, CS%ADp, CS%tv%C_p) - call register_tracer_diagnostics(CS%tracer_Reg, Time, diag, G, GV) - call register_diags_TS_tendency(Time, G, CS) + call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, diag, CS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) endif @@ -2461,64 +2451,6 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) end subroutine register_diags -!> Initialize diagnostics for temp/heat and saln/salt tendencies. -subroutine register_diags_TS_tendency(Time, G, CS) - type(time_type), intent(in) :: Time !< current model time - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(MOM_control_struct), pointer :: CS !< control structure set up by initialize_MOM - - type(diag_ctrl), pointer :: diag - integer :: i, j, k - integer :: isd, ied, jsd, jed, nz - integer :: is, ie, js, je - - diag => CS%diag - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! net temperature and heat tendencies - CS%id_Th_tendency = register_diag_field('ocean_model', 'Th_tendency', diag%axesTL, Time, & - 'Net time tendency for heat', 'W m-2', & - cmor_field_name="opottemptend", & - cmor_standard_name="tendency_of_sea_water_potential_temperature_expressed_as_heat_content", & - cmor_long_name ="Tendency of Sea Water Potential Temperature Expressed as Heat Content", & - v_extensive=.true.) - CS%id_Th_tendency_2d = register_diag_field('ocean_model', 'Th_tendency_2d', diag%axesT1, Time, & - 'Vertical sum of net time tendency for heat', 'W m-2', & - cmor_field_name="opottemptend_2d", & - cmor_standard_name="tendency_of_sea_water_potential_temperature_expressed_as_heat_content_vertical_sum",& - cmor_long_name ="Tendency of Sea Water Potential Temperature Expressed as Heat Content Vertical Sum") - if (CS%id_Th_tendency > 0 .or. CS%id_Th_tendency_2d > 0) then - CS%tendency_diagnostics = .true. - call safe_alloc_ptr(CS%Th_prev,isd,ied,jsd,jed,nz) - do k=1,nz ; do j=js,je ; do i=is,ie - CS%Th_prev(i,j,k) = CS%tv%T(i,j,k) * CS%h(i,j,k) - enddo ; enddo ; enddo - endif - - ! net salinity and salt tendencies - CS%id_Sh_tendency = register_diag_field('ocean_model', 'Sh_tendency', diag%axesTL, Time,& - 'Net time tendency for salt', 'kg m-2 s-1', & - cmor_field_name="osalttend", & - cmor_standard_name="tendency_of_sea_water_salinity_expressed_as_salt_content", & - cmor_long_name ="Tendency of Sea Water Salinity Expressed as Salt Content", & - v_extensive=.true.) - CS%id_Sh_tendency_2d = register_diag_field('ocean_model', 'Sh_tendency_2d', diag%axesT1, Time, & - 'Vertical sum of net time tendency for salt', 'kg m-2 s-1', & - cmor_field_name="osalttend_2d", & - cmor_standard_name="tendency_of_sea_water_salinity_expressed_as_salt_content_vertical_sum",& - cmor_long_name ="Tendency of Sea Water Salinity Expressed as Salt Content Vertical Sum") - if (CS%id_Sh_tendency > 0 .or. CS%id_Sh_tendency_2d > 0) then - CS%tendency_diagnostics = .true. - call safe_alloc_ptr(CS%Sh_prev,isd,ied,jsd,jed,nz) - do k=1,nz ; do j=js,je ; do i=is,ie - CS%Sh_prev(i,j,k) = CS%tv%S(i,j,k) * CS%h(i,j,k) - enddo ; enddo ; enddo - endif - -end subroutine register_diags_TS_tendency - - !> Initialize diagnostics for the variance decay of temp/salt !! across regridding/remapping subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS) @@ -2705,49 +2637,6 @@ subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) endif endif - if(.not. CS%tendency_diagnostics) return - - Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval - ppt2mks = 0.001 - work3d(:,:,:) = 0.0 - work2d(:,:) = 0.0 - - ! diagnose net tendency for heat content of a grid cell over a time step and update Th_prev - if (CS%id_Th_tendency > 0 .or. CS%id_Th_tendency_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = (tv%T(i,j,k)*CS%h(i,j,k) - CS%Th_prev(i,j,k)) * Idt * (GV%H_to_kg_m2 * tv%C_p) - CS%Th_prev(i,j,k) = tv%T(i,j,k)*CS%h(i,j,k) - enddo ; enddo ; enddo - if (CS%id_Th_tendency > 0) call post_data(CS%id_Th_tendency, work3d, diag) - if (CS%id_Th_tendency_2d > 0) then - do j=js,je ; do i=is,ie - work2d(i,j) = 0.0 - do k=1,nz - work2d(i,j) = work2d(i,j) + work3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_Th_tendency_2d, work2d, diag) - endif - endif - - ! diagnose net tendency for salt content of a grid cell over a time step and update Sh_prev - if (CS%id_Sh_tendency > 0 .or. CS%id_Sh_tendency_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work3d(i,j,k) = (tv%S(i,j,k)*CS%h(i,j,k) - CS%Sh_prev(i,j,k)) * Idt * (GV%H_to_kg_m2 * ppt2mks) - CS%Sh_prev(i,j,k) = tv%S(i,j,k)*CS%h(i,j,k) - enddo ; enddo ; enddo - if (CS%id_Sh_tendency > 0) call post_data(CS%id_Sh_tendency, work3d, diag) - if (CS%id_Sh_tendency_2d > 0) then - do j=js,je ; do i=is,ie - work2d(i,j) = 0.0 - do k=1,nz - work2d(i,j) = work2d(i,j) + work3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_Sh_tendency_2d, work2d, diag) - endif - endif - end subroutine post_TS_diagnostics !> Calculate and post variance decay diagnostics for temp/salt diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 93b46bf699..c4902fa923 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -56,6 +56,8 @@ module MOM_tracer_registry real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous !! timestep used for diagnostics + real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array + !! at a previous timestep used for diagnostics character(len=32) :: name !< tracer name used for diagnostics and error messages type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer @@ -71,13 +73,16 @@ module MOM_tracer_registry character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. real :: conv_scale = 1.0 !< A scaling factor used to convert the flux !! convergence of this tracer to its desired units. + character(len=48) :: cmor_tendname = "" !< The CMOR variable name for tendencies of this + !! tracer, required because CMOR does not follow any + !! discernable pattern for these names. integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. integer :: id_tr = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_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_tendency = -1 + integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 end type tracer_type !> Type to carry basic tracer information @@ -98,7 +103,7 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a df_x, df_y, OBC_inflow, OBC_in_u, OBC_in_v, & ad_2d_x, ad_2d_y, df_2d_x, df_2d_y, advection_xy, registry_diags, & flux_nameroot, flux_longname, flux_units, flux_scale, & - convergence_units, convergence_scale, diag_form) + convergence_units, convergence_scale, cmor_tendname, diag_form) type(hor_index_type), intent(in) :: HI !< horizontal index type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), target :: tr1 !< pointer to the tracer (concentration units) @@ -141,6 +146,7 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of this tracer. real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux !! convergence of this tracer to its desired units. + character(len=*), optional, intent(in) :: cmor_tendname !< The CMOR name for the layer-integrated tendencies of this tracer. integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the character !! string template to use in labeling diagnostics integer :: ntr @@ -189,6 +195,9 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a Reg%Tr(ntr)%conv_units = "" if (present(convergence_units)) Reg%Tr(ntr)%conv_units = convergence_units + Reg%Tr(ntr)%cmor_tendname = "" + if (present(cmor_tendname)) Reg%Tr(ntr)%cmor_tendname = cmor_tendname + Reg%Tr(ntr)%conv_scale = 1.0 if (present(convergence_scale)) then Reg%Tr(ntr)%conv_scale = convergence_scale @@ -318,12 +327,14 @@ end subroutine add_tracer_diagnostics !> register_tracer_diagnostics does a set of register_diag_field calls for any previously !! registered in a tracer registry with a value of registry_diags set to .true. -subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) +subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses type(time_type), intent(in) :: Time !< current model time type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure character(len=24) :: name ! A variable's name in a NetCDF file. character(len=24) :: shortnm ! A shortened version of a variable's name for @@ -335,8 +346,11 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) ! [units] m3 s-1 or [units] kg s-1. character(len=48) :: conv_units ! The units for flux convergences, either ! [units] m2 s-1 or [units] kg s-1. - character(len=72) :: cmorname ! The CMOR name of that variable. + character(len=72) :: cmorname ! The CMOR name of that variable. character(len=120) :: cmor_longname ! The CMOR long name of that variable. + character(len=120) :: var_lname ! A temporary longname for a diagnostic. + character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic + character(len=72) :: cmor_varname ! The temporary CMOR name for a diagnostic type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -448,6 +462,34 @@ subroutine register_tracer_diagnostics(Reg, Time, diag, G, GV) enddo ; enddo ; enddo endif + var_lname = "Net time tendency for "//lowercase(flux_longname) + if (len_trim(Tr%cmor_tendname) == 0) then + Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & + diag%axesTL, Time, var_lname, conv_units, & + v_extensive=.true.) + Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units) + else + cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//trim(flux_longname)//" Content" + Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & + diag%axesTL, Time, var_lname, conv_units, & + cmor_field_name=Tr%cmor_tendname, & + cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & + v_extensive=.true., conversion=Tr%conv_scale) + cmor_var_lname = trim(cmor_var_lname)//" Vertical Sum" + Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & + cmor_field_name=trim(Tr%cmor_tendname)//"_2d", & + cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & + conversion=Tr%conv_scale) + endif + if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then + call safe_alloc_ptr(Tr%Trxh_prev,isd,ied,jsd,jed,nz) + do k=1,nz ; do j=js,je ; do i=is,ie + Tr%Trxh_prev(i,j,k) = Tr%t(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + endif + ! call register_Z_tracer(Tr%t, name, longname, units, & ! Time, G, diag_to_Z_CSp) endif ; enddo @@ -456,14 +498,16 @@ end subroutine register_tracer_diagnostics !> post_tracer_diagnostics does post_data calls for any diagnostics that are !! being handled via the tracer registry. -subroutine post_tracer_diagnostics(Reg, diag, G, GV, dt) - type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry - type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output +subroutine post_tracer_diagnostics(Reg, h, diag, G, GV, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses + type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output real, intent(in) :: dt !< total time step for tracer updates - real :: work3d(SZI_(G),SZJ_(G),SZK_(G)) + real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) real :: work2d(SZI_(G),SZJ_(G)) real :: Idt type(tracer_type), pointer :: Tr=>NULL() @@ -499,6 +543,20 @@ subroutine post_tracer_diagnostics(Reg, diag, G, GV, dt) enddo ; enddo ; enddo call post_data(Tr%id_tendency, work3d, diag) endif + if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then + do k=1,nz ; do j=js,je ; do i=is,ie + work3d(i,j,k) = (Tr%t(i,j,k)*h(i,j,k) - Tr%Trxh_prev(i,j,k)) * Idt + Tr%Trxh_prev(i,j,k) = Tr%t(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + if (Tr%id_trxh_tendency > 0) call post_data(Tr%id_trxh_tendency, work3d, diag) + if (Tr%id_trxh_tendency_2d > 0) then + work2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work2d(i,j) = work2d(i,j) + work3d(i,j,k) + enddo ; enddo ; enddo + call post_data(Tr%id_trxh_tendency_2d, work2d, diag) + endif + endif endif ; enddo end subroutine post_tracer_diagnostics From 83bd1b719e0158c996c8433609b9201cc5fe8ec2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 4 Jan 2018 19:24:29 -0500 Subject: [PATCH 092/170] Removed trailing white space --- src/core/MOM.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f6da1b928f..af85d12c99 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1829,7 +1829,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo CS%vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) - else + else CS%vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & conversion=CS%tv%C_p) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c4902fa923..d03faf0205 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -355,7 +355,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV) integer :: i, j, k, is, ie, js, je, nz, m integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_diagnostics: "// & From a34e88e57a5826e25540081197af65b6a22d326d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jan 2018 13:02:56 -0500 Subject: [PATCH 093/170] +Containerized diagnostic IDs in MOM.F90 Created a structure of diagnostic IDs in MOM.F90 in preparation for moving many of these diagnostics out of MOM.F90 and eventually splitting MOM.F90 into a several smaller and more managable peices. Also revised adjst_ssh_for_p_atm to avoid using the overall MOM6 control structure. All answers and diagnostics are bitwise identical, but there are several changes to argument lists. --- src/core/MOM.F90 | 406 ++++++++++++++++++++++++----------------------- 1 file changed, 205 insertions(+), 201 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index af85d12c99..003b10f7e9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -146,6 +146,46 @@ module MOM #include +!> A structure with diagnostic IDs +type MOM_diag_IDs + ! diagnostic ids + + ! 3-d state fields + integer :: id_u = -1, id_v = -1, id_h = -1 + integer :: id_Tpot = -1, id_Sprac = -1 + + ! 2-d surface and bottom fields + integer :: id_zos = -1 + integer :: id_zossq = -1 + integer :: id_volo = -1 + integer :: id_ssh = -1 + integer :: id_ssh_ga = -1 + integer :: id_sst = -1 + integer :: id_sst_sq = -1 + integer :: id_sss = -1 + integer :: id_sss_sq = -1 + integer :: id_ssu = -1 + integer :: id_ssv = -1 + integer :: id_speed = -1 + integer :: id_ssh_inst = -1 + integer :: id_tob = -1 + integer :: id_sob = -1 + integer :: id_sstcon = -1 + integer :: id_sssabs = -1 + + integer :: id_T_vardec = -1, id_S_vardec = -1 + + ! heat and salt flux fields + integer :: id_fraz = -1 + integer :: id_salt_deficit = -1 + integer :: id_Heat_PmE = -1 + integer :: id_intern_heat = -1 + + ! Diagnostics for tracer horizontal transport + integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = -1 + integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 +end type MOM_diag_IDs + !> Control structure for this module type, public :: MOM_control_struct real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: & @@ -284,48 +324,7 @@ module MOM logical :: tendency_diagnostics = .false. - ! diagnostic ids - - ! 3-d state fields - integer :: id_u = -1 - integer :: id_v = -1 - integer :: id_h = -1 - integer :: id_Tpot = -1 - integer :: id_Sprac = -1 - - ! 2-d surface and bottom fields - integer :: id_zos = -1 - integer :: id_zossq = -1 - integer :: id_volo = -1; - integer :: id_ssh = -1 - integer :: id_ssh_ga = -1 - integer :: id_sst = -1 - integer :: id_sst_sq = -1 - integer :: id_sss = -1 - integer :: id_sss_sq = -1 - integer :: id_ssu = -1 - integer :: id_ssv = -1 - integer :: id_speed = -1 - integer :: id_ssh_inst = -1 - integer :: id_tob = -1 - integer :: id_sob = -1 - integer :: id_sstcon = -1 - integer :: id_sssabs = -1 - - ! heat and salt flux fields - integer :: id_fraz = -1 - integer :: id_salt_deficit = -1 - integer :: id_Heat_PmE = -1 - integer :: id_intern_heat = -1 - - ! variance decay for temp and heat - integer :: id_T_vardec = -1 - integer :: id_S_vardec = -1 - - - ! Diagnostics for tracer horizontal transport - integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = 1 - integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = 1 + type(MOM_diag_IDs) :: IDs ! The remainder provides pointers to child module control structures. type(MOM_dyn_unsplit_CS), pointer :: dyn_unsplit_CSp => NULL() @@ -410,6 +409,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) type(ocean_grid_type), pointer :: G ! pointer to a structure containing ! metrics and related information type(verticalGrid_type), pointer :: GV => NULL() + type(MOM_diag_IDs), pointer :: IDs => NULL() ! A structure with the diagnostic IDs. integer, save :: nt_debug = 1 ! running number of iterations, for debugging only. integer :: ntstep ! time steps between tracer updates or diabatic forcing integer :: n_max ! number of steps to take in this call @@ -461,7 +461,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! These are used for group halo passes. logical :: do_pass_Ray, do_pass_kv_bbl_thick - G => CS%G ; GV => CS%GV + G => CS%G ; GV => CS%GV ; IDs => CS%IDs 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 isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -721,7 +721,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif ! Store pre-dynamics state for proper diagnostic remapping if mass transports requested - if (transport_remap_grid_needed(CS)) then + if (transport_remap_grid_needed(IDs)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied h_pre_dyn(i,j,k) = h(i,j,k) if (associated(CS%tv%T)) T_pre_dyn(i,j,k) = CS%tv%T(i,j,k) @@ -878,10 +878,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call enable_averaging(dt, Time_local, CS%diag) ! These diagnostics are available every time step. - if (CS%id_u > 0) call post_data(CS%id_u, u, CS%diag) - if (CS%id_v > 0) call post_data(CS%id_v, v, CS%diag) - if (CS%id_h > 0) call post_data(CS%id_h, h, CS%diag) - if (CS%id_ssh_inst > 0) call post_data(CS%id_ssh_inst, ssh, CS%diag) + if (IDs%id_u > 0) call post_data(IDs%id_u, u, CS%diag) + if (IDs%id_v > 0) call post_data(IDs%id_v, v, CS%diag) + if (IDs%id_h > 0) call post_data(IDs%id_h, h, CS%diag) + if (IDs%id_ssh_inst > 0) call post_data(IDs%id_ssh_inst, ssh, CS%diag) call disable_averaging(CS%diag) if (CS%t_dyn_rel_adv == 0.0) then @@ -891,7 +891,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, fluxes, CS%t_dyn_rel_diag, G, GV, CS%diagnostics_CSp) call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag, G, GV, CS%t_dyn_rel_diag) - call post_TS_diagnostics(CS, G, GV, CS%tv, CS%diag, CS%t_dyn_rel_diag) + call post_TS_diagnostics(CS, IDs, G, GV, CS%tv, CS%diag, CS%t_dyn_rel_diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) CS%t_dyn_rel_diag = 0.0 @@ -921,7 +921,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) CS%ave_ssh(i,j) = CS%ave_ssh(i,j)*Itot_wt_ssh ssh(i,j) = CS%ave_ssh(i,j) enddo ; enddo - call adjust_ssh_for_p_atm(CS, G, GV, CS%ave_ssh, forces%p_surf_SSH) + call adjust_ssh_for_p_atm(CS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) if (CS%interp_p_surf) then ; do j=jsd,jed ; do i=isd,ied CS%p_surf_prev(i,j) = forces%p_surf(i,j) @@ -933,8 +933,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! Do diagnostics that only occur at the end of a complete forcing step. call cpu_clock_begin(id_clock_diagnostics) call enable_averaging(dt*n_max, Time_local, CS%diag) - call post_integrated_diagnostics(CS, G, GV, CS%diag, dt*n_max, CS%tv, ssh, fluxes) - call post_surface_diagnostics(CS, G, CS%diag, sfc_state) + call post_integrated_diagnostics(CS, IDs, G, GV, CS%diag, dt*n_max, CS%tv, ssh, fluxes) + call post_surface_diagnostics(CS, IDs, G, CS%diag, sfc_state) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -993,7 +993,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) - call post_transport_diagnostics(G, GV, CS, CS%diag, CS%t_dyn_rel_adv, h, & + call post_transport_diagnostics(G, GV, CS, CS%IDs, CS%diag, CS%t_dyn_rel_adv, h, & h_pre_dyn, T_pre_dyn, S_pre_dyn) ! Rebuild the remap grids now that we've posted the fields which rely on thicknesses ! from before the dynamics calls @@ -1145,7 +1145,8 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm ! happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) - call post_diags_TS_vardec(G, CS, dtdia) + call post_diags_TS_vardec(G, CS, CS%IDs, CS%diag, dtdia) + if (CS%debug) then call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2) call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) @@ -1364,7 +1365,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif - call adjust_ssh_for_p_atm(CS, G, GV, CS%ave_ssh, forces%p_surf_SSH) + call adjust_ssh_for_p_atm(CS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) call calculate_surface_state(sfc_state, CS%u, CS%v, CS%h, CS%ave_ssh, G, GV, CS) call disable_averaging(CS%diag) @@ -2168,13 +2169,13 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call tracer_hor_diff_init(Time, G, param_file, diag, CS%tracer_diff_CSp, CS%neutral_diffusion_CSp) if (CS%use_ALE_algorithm) & - call register_diags_TS_vardec(Time, G%HI, GV, param_file, CS) + call register_diags_TS_vardec(Time, G%HI, GV, param_file, CS, CS%IDs, CS%diag) call lock_tracer_registry(CS%tracer_Reg) call callTree_waypoint("tracer registry now locked (initialize_MOM)") ! now register some diagnostics since tracer registry is locked - call register_diags(Time, G, GV, CS, CS%ADp, CS%tv%C_p) + call register_diags(Time, G, GV, CS, CS%IDs, CS%diag, CS%ADp, CS%tv%C_p, CS%missing) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, diag, CS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) @@ -2305,118 +2306,109 @@ subroutine finish_MOM_initialization(Time, dirs, CS, fluxes) end subroutine finish_MOM_initialization !> Register the diagnostics -subroutine register_diags(Time, G, GV, CS, ADp, C_p) +subroutine register_diags(Time, G, GV, CS, IDs, diag, ADp, C_p, missing) type(time_type), intent(in) :: Time !< current model time type(ocean_grid_type), intent(inout) :: G !< ocean grid structu type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure type(MOM_control_struct), pointer :: CS !< control structure set up by initialize_MOM + type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output type(accel_diag_ptrs), intent(inout) :: ADp !< structure pointing to accelerations in momentum equation real, intent(in) :: C_p !< Heat capacity used in conversion to watts + real, intent(in) :: missing !< The value to use to fill in missing data - real :: conv2watt, conv2salt, H_convert - character(len=48) :: thickness_units, flux_units, S_flux_units - type(diag_ctrl), pointer :: diag + real :: H_convert + character(len=48) :: thickness_units integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - diag => CS%diag - thickness_units = get_thickness_units(GV) - flux_units = get_flux_units(GV) - S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg s-1"? - conv2watt = GV%H_to_kg_m2 * C_p if (GV%Boussinesq) then - conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? H_convert = GV%H_to_m else - conv2salt = GV%H_to_kg_m2 H_convert = GV%H_to_kg_m2 endif - !Initialize the diagnostics mask arrays. - !This has to be done after MOM_initialize_state call. - !call diag_masks_set(G, CS%missing) - - CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & + IDs%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & 'Zonal velocity', 'm s-1', cmor_field_name='uo', & cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') - CS%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & + IDs%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & 'Meridional velocity', 'm s-1', cmor_field_name='vo', & cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') - CS%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & + IDs%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & 'Layer Thickness', thickness_units, v_extensive=.true., conversion=H_convert) - CS%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& + IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& long_name='Total volume of liquid ocean', units='m3', & standard_name='sea_water_volume') - CS%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& + IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& standard_name = 'sea_surface_height_above_geoid', & - long_name= 'Sea surface height above geoid', units='m', missing_value=CS%missing) - CS%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& + long_name= 'Sea surface height above geoid', units='m', missing_value=missing) + IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& standard_name='square_of_sea_surface_height_above_geoid', & - long_name='Square of sea surface height above geoid', units='m2', missing_value=CS%missing) - CS%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & - 'Sea Surface Height', 'm', CS%missing) - CS%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& + long_name='Square of sea surface height above geoid', units='m2', missing_value=missing) + IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & + 'Sea Surface Height', 'm', missing) + IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& long_name='Area averaged sea surface height', units='m', & standard_name='area_averaged_sea_surface_height') - CS%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, Time, & - 'Instantaneous Sea Surface Height', 'm', CS%missing) - CS%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & - 'Sea Surface Zonal Velocity', 'm s-1', CS%missing) - CS%id_ssv = register_diag_field('ocean_model', 'SSV', diag%axesCv1, Time, & - 'Sea Surface Meridional Velocity', 'm s-1', CS%missing) - CS%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & - 'Sea Surface Speed', 'm s-1', CS%missing) + IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, Time, & + 'Instantaneous Sea Surface Height', 'm', missing) + IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & + 'Sea Surface Zonal Velocity', 'm s-1', missing) + IDs%id_ssv = register_diag_field('ocean_model', 'SSV', diag%axesCv1, Time, & + 'Sea Surface Meridional Velocity', 'm s-1', missing) + IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & + 'Sea Surface Speed', 'm s-1', missing) if (CS%use_temperature) then - CS%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & + IDs%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & long_name='Sea Water Potential Temperature at Sea Floor', & standard_name='sea_water_potential_temperature_at_sea_floor', units='degC') - CS%id_sob = register_diag_field('ocean_model','sob',diag%axesT1, Time, & + IDs%id_sob = register_diag_field('ocean_model','sob',diag%axesT1, Time, & long_name='Sea Water Salinity at Sea Floor', & standard_name='sea_water_salinity_at_sea_floor', units='psu') - CS%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & - 'Sea Surface Temperature', 'degC', CS%missing, cmor_field_name='tos', & + IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & + 'Sea Surface Temperature', 'degC', missing, cmor_field_name='tos', & cmor_long_name='Sea Surface Temperature', & cmor_standard_name='sea_surface_temperature') - CS%id_sst_sq = register_diag_field('ocean_model', 'SST_sq', diag%axesT1, Time, & - 'Sea Surface Temperature Squared', 'degC2', CS%missing, cmor_field_name='tossq', & + IDs%id_sst_sq = register_diag_field('ocean_model', 'SST_sq', diag%axesT1, Time, & + 'Sea Surface Temperature Squared', 'degC2', missing, cmor_field_name='tossq', & cmor_long_name='Square of Sea Surface Temperature ', & cmor_standard_name='square_of_sea_surface_temperature') - CS%id_sss = register_diag_field('ocean_model', 'SSS', diag%axesT1, Time, & - 'Sea Surface Salinity', 'psu', CS%missing, cmor_field_name='sos', & + IDs%id_sss = register_diag_field('ocean_model', 'SSS', diag%axesT1, Time, & + 'Sea Surface Salinity', 'psu', missing, cmor_field_name='sos', & cmor_long_name='Sea Surface Salinity', & cmor_standard_name='sea_surface_salinity') - CS%id_sss_sq = register_diag_field('ocean_model', 'SSS_sq', diag%axesT1, Time, & - 'Sea Surface Salinity Squared', 'psu', CS%missing, cmor_field_name='sossq', & + IDs%id_sss_sq = register_diag_field('ocean_model', 'SSS_sq', diag%axesT1, Time, & + 'Sea Surface Salinity Squared', 'psu', missing, cmor_field_name='sossq', & cmor_long_name='Square of Sea Surface Salinity ', & cmor_standard_name='square_of_sea_surface_salinity') if (CS%use_conT_absS) then - CS%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, Time, & + IDs%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, Time, & 'Potential Temperature', 'degC') - CS%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, Time, & + IDs%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, Time, & 'Salinity', 'psu') - CS%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & - 'Sea Surface Conservative Temperature', 'Celsius', CS%missing) - CS%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & - 'Sea Surface Absolute Salinity', 'g kg-1', CS%missing) + IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & + 'Sea Surface Conservative Temperature', 'Celsius', missing) + IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & + 'Sea Surface Absolute Salinity', 'g kg-1', missing) endif endif if (CS%use_temperature .and. CS%use_frazil) then - CS%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & + IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') endif - CS%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & + IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & 'Salt sink in ocean due to ice flux', 'psu m-2 s-1') - CS%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & + IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & 'Heat flux into ocean from mass flux into ocean', 'W m-2') - CS%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& + IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') if (CS%debug_truncations) then @@ -2429,22 +2421,22 @@ subroutine register_diags(Time, G, GV, CS, ADp, C_p) endif ! Diagnostics related to tracer transport - CS%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & + IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & 'Accumulated zonal thickness fluxes to advect tracers', 'kg', & y_cell_method='sum', v_extensive=.true., conversion=H_convert) - CS%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & + IDs%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & 'Accumulated meridional thickness fluxes to advect tracers', 'kg', & x_cell_method='sum', v_extensive=.true., conversion=H_convert) - CS%id_umo = register_diag_field('ocean_model', 'umo', & + IDs%id_umo = register_diag_field('ocean_model', 'umo', & diag%axesCuL, Time, 'Ocean Mass X Transport', 'kg s-1', & standard_name='ocean_mass_x_transport', y_cell_method='sum', v_extensive=.true.) - CS%id_vmo = register_diag_field('ocean_model', 'vmo', & + IDs%id_vmo = register_diag_field('ocean_model', 'vmo', & diag%axesCvL, Time, 'Ocean Mass Y Transport', 'kg s-1', & standard_name='ocean_mass_y_transport', x_cell_method='sum', v_extensive=.true.) - CS%id_umo_2d = register_diag_field('ocean_model', 'umo_2d', & + IDs%id_umo_2d = register_diag_field('ocean_model', 'umo_2d', & diag%axesCu1, Time, 'Ocean Mass X Transport Vertical Sum', 'kg s-1', & standard_name='ocean_mass_x_transport_vertical_sum', y_cell_method='sum') - CS%id_vmo_2d = register_diag_field('ocean_model', 'vmo_2d', & + IDs%id_vmo_2d = register_diag_field('ocean_model', 'vmo_2d', & diag%axesCv1, Time, 'Ocean Mass Y Transport Vertical Sum', 'kg s-1', & standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') @@ -2453,24 +2445,24 @@ end subroutine register_diags !> Initialize diagnostics for the variance decay of temp/salt !! across regridding/remapping -subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS) +subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS, IDs, diag) type(time_type), intent(in) :: Time !< current model time type(hor_index_type), intent(in) :: HI !< horizontal index type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(param_file_type), intent(in) :: param_file !< parameter file type(MOM_control_struct), pointer :: CS !< control structure for MOM + type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output integer :: isd, ied, jsd, jed, nz type(vardesc) :: vd_tmp - type(diag_ctrl), pointer :: diag - diag => CS%diag isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke ! variancy decay through ALE operation - CS%id_T_vardec = register_diag_field('ocean_model', 'T_vardec', diag%axesTL, Time, & + IDs%id_T_vardec = register_diag_field('ocean_model', 'T_vardec', diag%axesTL, Time, & 'ALE variance decay for temperature', 'degC2 s-1') - if (CS%id_T_vardec > 0) then + if (IDs%id_T_vardec > 0) then call safe_alloc_ptr(CS%T_squared,isd,ied,jsd,jed,nz) CS%T_squared(:,:,:) = 0. @@ -2478,9 +2470,9 @@ subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS) call register_tracer(CS%T_squared, vd_tmp, param_file, HI, GV, CS%tracer_reg) endif - CS%id_S_vardec = register_diag_field('ocean_model', 'S_vardec', diag%axesTL, Time, & + IDs%id_S_vardec = register_diag_field('ocean_model', 'S_vardec', diag%axesTL, Time, & 'ALE variance decay for salinity', 'psu2 s-1') - if (CS%id_S_vardec > 0) then + if (IDs%id_S_vardec > 0) then call safe_alloc_ptr(CS%S_squared,isd,ied,jsd,jed,nz) CS%S_squared(:,:,:) = 0. @@ -2522,10 +2514,12 @@ end subroutine MOM_timing_init !> This routine posts diagnostics of the transports, including the subgridscale !! contributions. -subroutine post_transport_diagnostics(G, GV, CS, diag, dt_trans, h, h_pre_dyn, T_pre_dyn, S_pre_dyn) +subroutine post_transport_diagnostics(G, GV, CS, IDs, diag, dt_trans, h, & + h_pre_dyn, T_pre_dyn, S_pre_dyn) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(MOM_control_struct), intent(in) :: CS !< control structure + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output real , intent(in) :: dt_trans !< total time step associated with the transports, in s. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -2552,58 +2546,59 @@ subroutine post_transport_diagnostics(G, GV, CS, diag, dt_trans, h, h_pre_dyn, T ! Post mass transports, including SGS ! Build the remap grids using the layer thicknesses from before the dynamics - if (transport_remap_grid_needed(CS)) & + if (transport_remap_grid_needed(IDs)) & call diag_update_remap_grids(diag, alt_h = h_pre_dyn, alt_T = T_pre_dyn, alt_S = S_pre_dyn) H_to_kg_m2_dt = GV%H_to_kg_m2 / dt_trans - if (CS%id_umo_2d > 0) then + if (IDs%id_umo_2d > 0) then umo2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do I=is-1,ie umo2d(I,j) = umo2d(I,j) + CS%uhtr(I,j,k) * H_to_kg_m2_dt enddo ; enddo ; enddo - call post_data(CS%id_umo_2d, umo2d, diag) + call post_data(IDs%id_umo_2d, umo2d, diag) endif - if (CS%id_umo > 0) then + if (IDs%id_umo > 0) then ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below do k=1,nz ; do j=js,je ; do I=is-1,ie umo(I,j,k) = CS%uhtr(I,j,k) * H_to_kg_m2_dt enddo ; enddo ; enddo - call post_data(CS%id_umo, umo, diag, alt_h = h_pre_dyn) + call post_data(IDs%id_umo, umo, diag, alt_h = h_pre_dyn) endif - if (CS%id_vmo_2d > 0) then + if (IDs%id_vmo_2d > 0) then vmo2d(:,:) = 0.0 do k=1,nz ; do J=js-1,je ; do i=is,ie vmo2d(i,J) = vmo2d(i,J) + CS%vhtr(i,J,k) * H_to_kg_m2_dt enddo ; enddo ; enddo - call post_data(CS%id_vmo_2d, vmo2d, diag) + call post_data(IDs%id_vmo_2d, vmo2d, diag) endif - if (CS%id_vmo > 0) then + if (IDs%id_vmo > 0) then ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below do k=1,nz ; do J=js-1,je ; do i=is,ie vmo(i,J,k) = CS%vhtr(i,J,k) * H_to_kg_m2_dt enddo ; enddo ; enddo - call post_data(CS%id_vmo, vmo, diag, alt_h = h_pre_dyn) + call post_data(IDs%id_vmo, vmo, diag, alt_h = h_pre_dyn) endif - if (CS%id_uhtr > 0) call post_data(CS%id_uhtr, CS%uhtr, diag, alt_h = h_pre_dyn) - if (CS%id_vhtr > 0) call post_data(CS%id_vhtr, CS%vhtr, diag, alt_h = h_pre_dyn) + if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, CS%uhtr, diag, alt_h = h_pre_dyn) + if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, CS%vhtr, diag, alt_h = h_pre_dyn) end subroutine post_transport_diagnostics !> Indicate whether it is necessary to save and recalculate the grid for finding !! remapped transports. -function transport_remap_grid_needed(CS) result(needed) - type(MOM_control_struct), intent(in) :: CS !< control structure +function transport_remap_grid_needed(IDs) result(needed) + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs logical :: needed needed = .false. - needed = needed .or. (CS%id_uhtr > 0) .or. (CS%id_vhtr > 0) - needed = needed .or. (CS%id_umo > 0) .or. (CS%id_vmo > 0) + needed = needed .or. (IDs%id_uhtr > 0) .or. (IDs%id_vhtr > 0) + needed = needed .or. (IDs%id_umo > 0) .or. (IDs%id_vmo > 0) end function transport_remap_grid_needed !> Post diagnostics of temperatures and salinities, their fluxes, and tendencies. -subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) +subroutine post_TS_diagnostics(CS, IDs, G, GV, tv, diag, dt) type(MOM_control_struct), intent(inout) :: CS !< control structure + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables @@ -2619,30 +2614,32 @@ subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) if (.NOT. CS%use_conT_absS) then ! Internal T&S variables are potential temperature & practical salinity - if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,G%ke), diag, mask=G%mask2dT) - if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,G%ke), diag, mask=G%mask2dT) + if (IDs%id_tob > 0) call post_data(IDs%id_tob, tv%T(:,:,G%ke), diag, mask=G%mask2dT) + if (IDs%id_sob > 0) call post_data(IDs%id_sob, tv%S(:,:,G%ke), diag, mask=G%mask2dT) else ! Internal T&S variables are conservative temperature & absolute salinity, ! so they need to converted to potential temperature and practical salinity ! for some diagnostics using TEOS-10 function calls. - if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0) .or. (CS%id_Sprac > 0) .or. (CS%id_sob > 0)) then + if ((IDs%id_Tpot > 0) .or. (IDs%id_tob > 0) .or. (IDs%id_Sprac > 0) .or. (IDs%id_sob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie pracSal(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) potTemp(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) enddo; enddo ; enddo - if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, potTemp, diag) - if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, pracSal, diag) - if (CS%id_tob > 0) call post_data(CS%id_tob, potTemp(:,:,G%ke), diag, mask=G%mask2dT) - if (CS%id_sob > 0) call post_data(CS%id_sob, pracSal(:,:,G%ke), diag, mask=G%mask2dT) + if (IDs%id_Tpot > 0) call post_data(IDs%id_Tpot, potTemp, diag) + if (IDs%id_Sprac > 0) call post_data(IDs%id_Sprac, pracSal, diag) + if (IDs%id_tob > 0) call post_data(IDs%id_tob, potTemp(:,:,G%ke), diag, mask=G%mask2dT) + if (IDs%id_sob > 0) call post_data(IDs%id_sob, pracSal(:,:,G%ke), diag, mask=G%mask2dT) endif endif end subroutine post_TS_diagnostics !> Calculate and post variance decay diagnostics for temp/salt -subroutine post_diags_TS_vardec(G, CS, dt) +subroutine post_diags_TS_vardec(G, CS, IDs, diag, dt) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(MOM_control_struct), intent(in) :: CS !< control structure + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output real, intent(in) :: dt !< total time step real :: work(SZI_(G),SZJ_(G),SZK_(G)) @@ -2652,24 +2649,25 @@ subroutine post_diags_TS_vardec(G, CS, dt) Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval - if (CS%id_T_vardec > 0) then + if (IDs%id_T_vardec > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work(i,j,k) = (CS%T_squared(i,j,k) - CS%tv%T(i,j,k)**2) * Idt enddo ; enddo ; enddo - call post_data(CS%id_T_vardec, work, CS%diag) + call post_data(IDs%id_T_vardec, work, diag) endif - if (CS%id_S_vardec > 0) then + if (IDs%id_S_vardec > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work(i,j,k) = (CS%S_squared(i,j,k) - CS%tv%S(i,j,k)**2) * Idt enddo ; enddo ; enddo - call post_data(CS%id_S_vardec, work, CS%diag) + call post_data(IDs%id_S_vardec, work, diag) endif end subroutine post_diags_TS_vardec !> This routine posts diagnostics of various integrated quantities. -subroutine post_integrated_diagnostics(CS, G, GV, diag, dt_int, tv, ssh, fluxes) +subroutine post_integrated_diagnostics(CS, IDs, G, GV, diag, dt_int, tv, ssh, fluxes) type(MOM_control_struct), intent(in) :: CS !< control structure + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output @@ -2699,19 +2697,19 @@ subroutine post_integrated_diagnostics(CS, G, GV, diag, dt_int, tv, ssh, fluxes) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ! area mean SSH - if (CS%id_ssh_ga > 0) then + if (IDs%id_ssh_ga > 0) then ssh_ga = global_area_mean(ssh, G) - call post_data(CS%id_ssh_ga, ssh_ga, diag) + call post_data(IDs%id_ssh_ga, ssh_ga, diag) endif I_time_int = 1.0 / dt_int - if (CS%id_ssh > 0) & - call post_data(CS%id_ssh, ssh, diag, mask=G%mask2dT) + if (IDs%id_ssh > 0) & + call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) ! post the dynamic sea level, zos, and zossq. ! zos is ave_ssh with sea ice inverse barometer removed, ! and with zero global area mean. - if(CS%id_zos > 0 .or. CS%id_zossq > 0) then + if(IDs%id_zos > 0 .or. IDs%id_zossq > 0) then allocate(zos(G%isd:G%ied,G%jsd:G%jed)) zos(:,:) = 0.0 do j=js,je ; do i=is,ie @@ -2727,80 +2725,81 @@ subroutine post_integrated_diagnostics(CS, G, GV, diag, dt_int, tv, ssh, fluxes) do j=js,je ; do i=is,ie zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean enddo ; enddo - if(CS%id_zos > 0) then - call post_data(CS%id_zos, zos, diag, mask=G%mask2dT) + if(IDs%id_zos > 0) then + call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) endif - if(CS%id_zossq > 0) then + if(IDs%id_zossq > 0) then allocate(zossq(G%isd:G%ied,G%jsd:G%jed)) zossq(:,:) = 0.0 do j=js,je ; do i=is,ie zossq(i,j) = zos(i,j)*zos(i,j) enddo ; enddo - call post_data(CS%id_zossq, zossq, diag, mask=G%mask2dT) + call post_data(IDs%id_zossq, zossq, diag, mask=G%mask2dT) deallocate(zossq) endif deallocate(zos) endif ! post total volume of the liquid ocean - if(CS%id_volo > 0) then + if(IDs%id_volo > 0) then allocate(tmp(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie tmp(i,j) = G%mask2dT(i,j)*(ssh(i,j) + G%bathyT(i,j)) enddo ; enddo volo = global_area_integral(tmp, G) - call post_data(CS%id_volo, volo, diag) + call post_data(IDs%id_volo, volo, diag) deallocate(tmp) endif ! post frazil - if (ASSOCIATED(tv%frazil) .and. (CS%id_fraz > 0)) then + if (ASSOCIATED(tv%frazil) .and. (IDs%id_fraz > 0)) then allocate(frazil_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie frazil_ave(i,j) = tv%frazil(i,j) * I_time_int enddo ; enddo - call post_data(CS%id_fraz, frazil_ave, diag, mask=G%mask2dT) + call post_data(IDs%id_fraz, frazil_ave, diag, mask=G%mask2dT) deallocate(frazil_ave) endif ! post the salt deficit - if (ASSOCIATED(tv%salt_deficit) .and. (CS%id_salt_deficit > 0)) then + if (ASSOCIATED(tv%salt_deficit) .and. (IDs%id_salt_deficit > 0)) then allocate(salt_deficit_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie salt_deficit_ave(i,j) = tv%salt_deficit(i,j) * I_time_int enddo ; enddo - call post_data(CS%id_salt_deficit, salt_deficit_ave, diag, mask=G%mask2dT) + call post_data(IDs%id_salt_deficit, salt_deficit_ave, diag, mask=G%mask2dT) deallocate(salt_deficit_ave) endif ! post temperature of P-E+R - if (ASSOCIATED(tv%TempxPmE) .and. (CS%id_Heat_PmE > 0)) then + if (ASSOCIATED(tv%TempxPmE) .and. (IDs%id_Heat_PmE > 0)) then allocate(Heat_PmE_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie Heat_PmE_ave(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(CS%id_Heat_PmE, Heat_PmE_ave, diag, mask=G%mask2dT) + call post_data(IDs%id_Heat_PmE, Heat_PmE_ave, diag, mask=G%mask2dT) deallocate(Heat_PmE_ave) endif ! post geothermal heating or internal heat source/sinks - if (ASSOCIATED(tv%internal_heat) .and. (CS%id_intern_heat > 0)) then + if (ASSOCIATED(tv%internal_heat) .and. (IDs%id_intern_heat > 0)) then allocate(intern_heat_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie intern_heat_ave(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(CS%id_intern_heat, intern_heat_ave, diag, mask=G%mask2dT) + call post_data(IDs%id_intern_heat, intern_heat_ave, diag, mask=G%mask2dT) deallocate(intern_heat_ave) endif end subroutine post_integrated_diagnostics !> This routine posts diagnostics of various ocean surface quantities. -subroutine post_surface_diagnostics(CS, G, diag, sfc_state) - type(MOM_control_struct), intent(in) :: CS !< control structure - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - type(surface), intent(in) :: sfc_state !< ocean surface state +subroutine post_surface_diagnostics(CS, IDs, G, diag, sfc_state) + type(MOM_control_struct), intent(in) :: CS !< control structure + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + type(surface), intent(in) :: sfc_state !< ocean surface state real, dimension(SZI_(G),SZJ_(G)) :: & potTemp, & ! TEOS10 potential temperature (deg C) @@ -2815,12 +2814,12 @@ subroutine post_surface_diagnostics(CS, G, diag, sfc_state) if (.NOT.CS%use_conT_absS) then !Internal T&S variables are assumed to be potential&practical - if (CS%id_sst > 0) call post_data(CS%id_sst, sfc_state%SST, diag, mask=G%mask2dT) - if (CS%id_sss > 0) call post_data(CS%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) + if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) + if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) else !Internal T&S variables are assumed to be conservative&absolute - if (CS%id_sstcon > 0) call post_data(CS%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) - if (CS%id_sssabs > 0) call post_data(CS%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) + if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) + if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) !Using TEOS-10 function calls convert T&S diagnostics !from conservative temp to potential temp and !from absolute salinity to practical salinity @@ -2828,34 +2827,34 @@ subroutine post_surface_diagnostics(CS, G, diag, sfc_state) pracSal(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) potTemp(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j),sfc_state%SST(i,j)) enddo ; enddo - if (CS%id_sst > 0) call post_data(CS%id_sst, potTemp, diag, mask=G%mask2dT) - if (CS%id_sss > 0) call post_data(CS%id_sss, pracSal, diag, mask=G%mask2dT) + if (IDs%id_sst > 0) call post_data(IDs%id_sst, potTemp, diag, mask=G%mask2dT) + if (IDs%id_sss > 0) call post_data(IDs%id_sss, pracSal, diag, mask=G%mask2dT) endif - if (CS%id_sst_sq > 0) then + if (IDs%id_sst_sq > 0) then do j=js,je ; do i=is,ie SST_sq(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j) enddo ; enddo - call post_data(CS%id_sst_sq, SST_sq, diag, mask=G%mask2dT) + call post_data(IDs%id_sst_sq, SST_sq, diag, mask=G%mask2dT) endif - if (CS%id_sss_sq > 0) then + if (IDs%id_sss_sq > 0) then do j=js,je ; do i=is,ie SSS_sq(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j) enddo ; enddo - call post_data(CS%id_sss_sq, SSS_sq, diag, mask=G%mask2dT) + call post_data(IDs%id_sss_sq, SSS_sq, diag, mask=G%mask2dT) endif - if (CS%id_ssu > 0) & - call post_data(CS%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) - if (CS%id_ssv > 0) & - call post_data(CS%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) + if (IDs%id_ssu > 0) & + call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) + if (IDs%id_ssv > 0) & + call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) - if (CS%id_speed > 0) then + if (IDs%id_speed > 0) then do j=js,je ; do i=is,ie sfc_speed(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) enddo ; enddo - call post_data(CS%id_speed, sfc_speed, diag, mask=G%mask2dT) + call post_data(IDs%id_speed, sfc_speed, diag, mask=G%mask2dT) endif call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) @@ -3087,33 +3086,38 @@ end subroutine set_restart_fields !> This subroutine applies a correction to the sea surface height to compensate !! for the atmospheric pressure (the inverse barometer). -subroutine adjust_ssh_for_p_atm(CS, G, GV, ssh, p_atm) - type(MOM_control_struct), intent(in) :: CS !< control structure +subroutine adjust_ssh_for_p_atm(tv, G, GV, ssh, p_atm, use_EOS) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: ssh !< time mean surface height (m) real, dimension(:,:), optional, pointer :: p_atm !< atmospheric pressure (Pascal) + logical, optional, intent(in) :: use_EOS !< If true, calculate the density for + !! the SSH correction using the equation of state. real :: Rho_conv ! The density used to convert surface pressure to ! a corrected effective SSH, in kg m-3. real :: IgR0 ! The SSH conversion factor from Pa to m. + logical :: calc_rho integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (ASSOCIATED(p_atm)) then + if (present(p_atm)) then ; if (ASSOCIATED(p_atm)) then + calc_rho = ASSOCIATED(tv%eqn_of_state) + if (present(use_EOS) .and. calc_rho) calc_rho = use_EOS ! Correct the output sea surface height for the contribution from the ! atmospheric pressure do j=js,je ; do i=is,ie - if ((ASSOCIATED(CS%tv%eqn_of_state)) .and. (CS%calc_rho_for_sea_lev)) then - call calculate_density(CS%tv%T(i,j,1), CS%tv%S(i,j,1), p_atm(i,j)/2.0, & - Rho_conv, CS%tv%eqn_of_state) + if (calc_rho) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), p_atm(i,j)/2.0, & + Rho_conv, tv%eqn_of_state) else Rho_conv=GV%Rho0 endif IgR0 = 1.0 / (Rho_conv * GV%g_Earth) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 enddo ; enddo - endif + endif ; endif end subroutine adjust_ssh_for_p_atm From b9101d7ef1f203cfae35e63aa0b1891d588be2eb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jan 2018 13:05:29 -0500 Subject: [PATCH 094/170] Corrected some indents in ocean_model_init Cleaned up some continuation line indents in ocean_model init, for no particularly good reason. --- config_src/coupled_driver/ocean_model_MOM.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index c72c816b38..cf854cfc41 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -254,7 +254,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") if (associated(OS)) then call MOM_error(WARNING, "ocean_model_init called with an associated "// & - "ocean_state_type structure. Model is already initialized.") + "ocean_state_type structure. Model is already initialized.") return endif allocate(OS) @@ -264,7 +264,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%Time = Time_in call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MOM_CSp, Time_in, & - offline_tracer_mode=offline_tracer_mode) + offline_tracer_mode=offline_tracer_mode) OS%grid => OS%MOM_CSp%G ; OS%GV => OS%MOM_CSp%GV OS%C_p = OS%MOM_CSp%tv%C_p OS%fluxes%C_p = OS%MOM_CSp%tv%C_p From 4c8777a3331e75bd1b3b2bac0728e4b7cbea81ff Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jan 2018 18:44:25 -0500 Subject: [PATCH 095/170] +Add T_is_conT and S_is_absS to thermo_var & surface Added two new elements, T_is_conT and S_is_absS to the thermo_var_pts and surface types, to permit the elimination of the use_conT_absS element of the overall MOM control structure. All answers are bitwise identical. --- src/core/MOM_variables.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index c2c7ad68ad..9adf55fda6 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -42,6 +42,10 @@ module MOM_variables ocean_salt, & !< The total salt content of the ocean in kgSalt m-2. salt_deficit !< The salt needed to maintain the ocean column at a minimum !! salinity of 0.01 PSU over the call to step_MOM, in kgSalt m-2. + logical :: T_is_conT = .false. !< If true, the temperature variable SST is + !! actually the conservative temperature, in degC. + logical :: S_is_absS = .false. !< If true, the salinity variable SSS is + !! actually the absolute salinity, in g/kg. real, pointer, dimension(:,:) :: & taux_shelf => NULL(), & !< The zonal and meridional stresses on the ocean tauy_shelf => NULL(), & !< under shelves, in Pa. @@ -81,6 +85,10 @@ module MOM_variables real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. !! When conservative temperature is used, this is !! constant and exactly 3991.86795711963 J K kg-1. + logical :: T_is_conT = .false. !< If true, the temperature variable tv%T is + !! actually the conservative temperature, in degC. + logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is + !! actually the absolute salinity, in g/kg. real, pointer, dimension(:,:) :: & ! These arrays are accumulated fluxes for communication with other components. frazil => NULL(), & !< The energy needed to heat the ocean column to the From 846847384d3a5a22a2b2e4ce826716226c5aefdb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Jan 2018 18:45:31 -0500 Subject: [PATCH 096/170] +Eliminated MOM_CSp%use_conT_absS Eliminated the use_conT_absS element of the MOM control structure, instead using T_is_conT and S_is_absS in the thermo_var and surface types to convey the information of what the T and S variables are. The led to argument changes to convert_state_to-ocean_type. Also eliminated unused arguments from post_TS_diagnostics, post_integrated_diagnostics, and post_surface_diagnostics. All solutions are bitwise identical, but there are changes to interfaces and types. --- config_src/coupled_driver/ocean_model_MOM.F90 | 27 +-- config_src/mct_driver/ocn_comp_mct.F90 | 34 ++-- src/core/MOM.F90 | 160 ++++++++++-------- 3 files changed, 122 insertions(+), 99 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index cf854cfc41..756c648120 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -408,8 +408,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& OS%grid, OS%GV, OS%MOM_CSp) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & - OS%MOM_CSp%use_conT_absS) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) endif @@ -625,8 +624,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! Translate state into Ocean. ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & - OS%MOM_CSp%use_conT_absS) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) call coupler_type_send_data(Ocean_sfc%fields, OS%Time) call callTree_leave("update_ocean_model()") @@ -904,14 +902,13 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, end subroutine initialize_ocean_public_type -subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, use_conT_absS, & +subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, & patm, press_to_z) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(ocean_public_type), & target, intent(inout) :: Ocean_sfc type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - logical, intent(in) :: use_conT_absS real, optional, intent(in) :: patm(:,:) real, optional, intent(in) :: press_to_z ! This subroutine translates the coupler's ocean_data_type into MOM's @@ -936,17 +933,24 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, use_conT_absS, & endif i0 = is - isc_bnd ; j0 = js - jsc_bnd - if (use_conT_absS) then - !If directed convert the surface T&S from conservative T to potential T and - !from absolute (reference) salinity to practical salinity + if (sfc_state%T_is_conT) then + ! Convert the surface T from conservative T to potential T. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(sfc_state%SSS(i+i0,j+j0)) Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(sfc_state%SSS(i+i0,j+j0), & sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%t_surf(i,j) = sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + endif + if (sfc_state%S_is_absS) then + ! Convert the surface S from absolute salinity to practical salinity. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(sfc_state%SSS(i+i0,j+j0)) + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%s_surf(i,j) = sfc_state%SSS(i+i0,j+j0) enddo ; enddo endif @@ -1029,8 +1033,7 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& OS%grid, OS%GV, OS%MOM_CSp) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & - OS%MOM_CSp%use_conT_absS) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) end subroutine ocean_model_init_sfc ! diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 99e2feeabe..5413164a99 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -942,8 +942,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& OS%grid, OS%GV, OS%MOM_CSp) - call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid, & - OS%MOM_CSp%use_conT_absS) + call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid) endif call close_param_file(param_file) @@ -973,8 +972,7 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& OS%grid, OS%GV, OS%MOM_CSp) - call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid, & - OS%MOM_CSp%use_conT_absS) + call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid) end subroutine ocean_model_init_sfc @@ -1344,13 +1342,10 @@ end subroutine initialize_ocean_public_type !> Translates the coupler's ocean_data_type into MOM6's surface state variable. !! This may eventually be folded into the MOM6's code that calculates the !! surface state in the first place. -subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, use_conT_absS, & - patm, press_to_z) +subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, patm, press_to_z) type(surface), intent(inout) :: state type(ocean_public_type), target, intent(inout) :: Ocean_sfc !< Ocean surface state type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - logical, intent(in) :: use_conT_absS !< If true, , the prognostics - !! T&S are the conservative temperature real, optional, intent(in) :: patm(:,:) !< Atmospheric pressure. real, optional, intent(in) :: press_to_z !< Factor to tranform atmospheric !! pressure to z? @@ -1373,18 +1368,24 @@ subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, use_conT_absS, & endif i0 = is - isc_bnd ; j0 = js - jsc_bnd - !If directed convert the surface T&S - !from conservative T to potential T and - !from absolute (reference) salinity to practical salinity - ! - if(use_conT_absS) then + if (state%T_is_conT) then + ! Convert the surface T from conservative T to potential T. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(state%SSS(i+i0,j+j0)) - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(state%SSS(i+i0,j+j0),state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(state%SSS(i+i0,j+j0), & + state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%t_surf(i,j) = state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + endif + if (state%S_is_absS) then + ! Convert the surface S from absolute salinity to practical salinity. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(state%SSS(i+i0,j+j0)) + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%s_surf(i,j) = state%SSS(i+i0,j+j0) enddo ; enddo endif @@ -1820,8 +1821,7 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & ! Translate state into Ocean. ! call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) - call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid, & - OS%MOM_CSp%use_conT_absS) + call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid) call callTree_leave("update_ocean_model()") end subroutine update_ocean_model diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 003b10f7e9..a8157cc543 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -236,10 +236,6 @@ module MOM !! with nkml sublayers and nkbl buffer layer. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical :: use_conT_absS !< If true, , the prognostics T&S are the conservative temperature - !! and absolute salinity. Care should be taken to convert them - !! to potential temperature and practical salinity before - !! exchanging them with the coupler and/or reporting T&S diagnostics. logical :: thickness_diffuse !< If true, diffuse interface height w/ a diffusivity KHTH. logical :: thickness_diffuse_first !< If true, diffuse thickness before dynamics. logical :: mixedlayer_restrat !< If true, use submesoscale mixed layer restratifying scheme. @@ -891,7 +887,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, fluxes, CS%t_dyn_rel_diag, G, GV, CS%diagnostics_CSp) call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag, G, GV, CS%t_dyn_rel_diag) - call post_TS_diagnostics(CS, IDs, G, GV, CS%tv, CS%diag, CS%t_dyn_rel_diag) + call post_TS_diagnostics(IDs, G, GV, CS%tv, CS%diag, CS%t_dyn_rel_diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) CS%t_dyn_rel_diag = 0.0 @@ -933,8 +929,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! Do diagnostics that only occur at the end of a complete forcing step. call cpu_clock_begin(id_clock_diagnostics) call enable_averaging(dt*n_max, Time_local, CS%diag) - call post_integrated_diagnostics(CS, IDs, G, GV, CS%diag, dt*n_max, CS%tv, ssh, fluxes) - call post_surface_diagnostics(CS, IDs, G, CS%diag, sfc_state) + call post_integrated_diagnostics(IDs, G, GV, CS%diag, dt*n_max, CS%tv, ssh, fluxes) + call post_surface_diagnostics(IDs, G, CS%diag, sfc_state, CS%tv) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1425,6 +1421,10 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo logical :: save_IC ! If true, save the initial conditions. logical :: do_unit_tests ! If true, call unit tests. logical :: test_grid_copy = .false. + logical :: use_conT_absS ! If true, the prognostics T & S are conservative temperature + ! and absolute salinity. Care should be taken to convert them + ! to potential temperature and practical salinity before + ! exchanging them with the coupler and/or reporting T&S diagnostics. logical :: use_ice_shelf ! Needed for ALE logical :: global_indexing ! If true use global horizontal index values instead ! of having the data domain on each processor start at 1. @@ -1511,12 +1511,13 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo "If true, apply diabatic and thermodynamic processes, \n"//& "including buoyancy forcing and mass gain or loss, \n"//& "before stepping the dynamics forward.", default=.false.) - call get_param(param_file, "MOM", "USE_CONTEMP_ABSSAL", CS%use_conT_absS, & - "If true, , the prognostics T&S are the conservative temperature \n"//& + call get_param(param_file, "MOM", "USE_CONTEMP_ABSSAL", use_conT_absS, & + "If true, the prognostics T&S are the conservative temperature \n"//& "and absolute salinity. Care should be taken to convert them \n"//& - "to potential temperature and practical salinity before \n"//& - "exchanging them with the coupler and/or reporting T&S diagnostics. \n"& - , default=.false.) + "to potential temperature and practical salinity before \n"//& + "exchanging them with the coupler and/or reporting T&S diagnostics.\n", & + default=.false.) + CS%tv%T_is_conT = use_conT_absS ; CS%tv%S_is_absS = use_conT_absS call get_param(param_file, "MOM", "ADIABATIC", CS%adiabatic, & "There are no diapycnal mass fluxes if ADIABATIC is \n"//& "true. This assumes that KD = KDML = 0.0 and that \n"//& @@ -1823,17 +1824,20 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ALLOC_(CS%T(isd:ied,jsd:jed,nz)) ; CS%T(:,:,:) = 0.0 ALLOC_(CS%S(isd:ied,jsd:jed,nz)) ; CS%S(:,:,:) = 0.0 CS%tv%T => CS%T ; CS%tv%S => CS%S - if (CS%use_conT_absS) then + if (CS%tv%T_is_conT) then CS%vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & conversion=CS%tv%C_p) - CS%vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & - cmor_field_name="so", cmor_longname="Sea Water Salinity", & - conversion=0.001) else CS%vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & conversion=CS%tv%C_p) + endif + if (CS%tv%S_is_absS) then + CS%vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & + cmor_field_name="so", cmor_longname="Sea Water Salinity", & + conversion=0.001) + else CS%vd_S = var_desc(name="salt",units="psu",longname="Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) @@ -1890,6 +1894,12 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo if (CS%debug_truncations) then allocate(CS%u_prev(IsdB:IedB,jsd:jed,nz)) ; CS%u_prev(:,:,:) = 0.0 allocate(CS%v_prev(isd:ied,JsdB:JedB,nz)) ; CS%v_prev(:,:,:) = 0.0 + call safe_alloc_ptr(CS%ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(CS%ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + if (.not.CS%adiabatic) then + call safe_alloc_ptr(CS%ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(CS%ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) + endif endif MOM_internal_state%u => CS%u ; MOM_internal_state%v => CS%v @@ -2175,7 +2185,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call callTree_waypoint("tracer registry now locked (initialize_MOM)") ! now register some diagnostics since tracer registry is locked - call register_diags(Time, G, GV, CS, CS%IDs, CS%diag, CS%ADp, CS%tv%C_p, CS%missing) + call register_diags(Time, G, GV, CS%IDs, CS%diag, CS%tv%C_p, CS%missing, CS%tv) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, diag, CS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) @@ -2305,17 +2315,16 @@ subroutine finish_MOM_initialization(Time, dirs, CS, fluxes) end subroutine finish_MOM_initialization -!> Register the diagnostics -subroutine register_diags(Time, G, GV, CS, IDs, diag, ADp, C_p, missing) - type(time_type), intent(in) :: Time !< current model time - type(ocean_grid_type), intent(inout) :: G !< ocean grid structu - type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure - type(MOM_control_struct), pointer :: CS !< control structure set up by initialize_MOM - type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. - type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - type(accel_diag_ptrs), intent(inout) :: ADp !< structure pointing to accelerations in momentum equation - real, intent(in) :: C_p !< Heat capacity used in conversion to watts - real, intent(in) :: missing !< The value to use to fill in missing data +!> Register certain diagnostics +subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) + type(time_type), intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + real, intent(in) :: C_p !< Heat capacity used in conversion to watts + real, intent(in) :: missing !< The value to use to fill in missing data + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real :: H_convert character(len=48) :: thickness_units @@ -2362,7 +2371,7 @@ subroutine register_diags(Time, G, GV, CS, IDs, diag, ADp, C_p, missing) IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & 'Sea Surface Speed', 'm s-1', missing) - if (CS%use_temperature) then + if (associated(tv%T)) then IDs%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & long_name='Sea Water Potential Temperature at Sea Floor', & standard_name='sea_water_potential_temperature_at_sea_floor', units='degC') @@ -2385,23 +2394,24 @@ subroutine register_diags(Time, G, GV, CS, IDs, diag, ADp, C_p, missing) 'Sea Surface Salinity Squared', 'psu', missing, cmor_field_name='sossq', & cmor_long_name='Square of Sea Surface Salinity ', & cmor_standard_name='square_of_sea_surface_salinity') - if (CS%use_conT_absS) then + if (tv%T_is_conT) then IDs%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, Time, & 'Potential Temperature', 'degC') - IDs%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, Time, & - 'Salinity', 'psu') IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & 'Sea Surface Conservative Temperature', 'Celsius', missing) + endif + if (tv%S_is_absS) then + IDs%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, Time, & + 'Salinity', 'psu') IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & 'Sea Surface Absolute Salinity', 'g kg-1', missing) endif - endif - - if (CS%use_temperature .and. CS%use_frazil) then - IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & - 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & - cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & - cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') + if (ASSOCIATED(tv%frazil)) then + IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & + 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & + cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & + cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') + endif endif IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & @@ -2411,15 +2421,6 @@ subroutine register_diags(Time, G, GV, CS, IDs, diag, ADp, C_p, missing) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') - if (CS%debug_truncations) then - call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) - if (.not.CS%adiabatic) then - call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) - endif - endif - ! Diagnostics related to tracer transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & 'Accumulated zonal thickness fluxes to advect tracers', 'kg', & @@ -2596,8 +2597,7 @@ function transport_remap_grid_needed(IDs) result(needed) end function transport_remap_grid_needed !> Post diagnostics of temperatures and salinities, their fluxes, and tendencies. -subroutine post_TS_diagnostics(CS, IDs, G, GV, tv, diag, dt) - type(MOM_control_struct), intent(inout) :: CS !< control structure +subroutine post_TS_diagnostics(IDs, G, GV, tv, diag, dt) type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -2612,22 +2612,33 @@ subroutine post_TS_diagnostics(CS, IDs, G, GV, tv, diag, dt) integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - if (.NOT. CS%use_conT_absS) then + if (.NOT.tv%T_is_conT) then ! Internal T&S variables are potential temperature & practical salinity if (IDs%id_tob > 0) call post_data(IDs%id_tob, tv%T(:,:,G%ke), diag, mask=G%mask2dT) - if (IDs%id_sob > 0) call post_data(IDs%id_sob, tv%S(:,:,G%ke), diag, mask=G%mask2dT) else ! Internal T&S variables are conservative temperature & absolute salinity, ! so they need to converted to potential temperature and practical salinity ! for some diagnostics using TEOS-10 function calls. - if ((IDs%id_Tpot > 0) .or. (IDs%id_tob > 0) .or. (IDs%id_Sprac > 0) .or. (IDs%id_sob > 0)) then + if ((IDs%id_Tpot > 0) .or. (IDs%id_tob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie - pracSal(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) potTemp(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) enddo; enddo ; enddo if (IDs%id_Tpot > 0) call post_data(IDs%id_Tpot, potTemp, diag) - if (IDs%id_Sprac > 0) call post_data(IDs%id_Sprac, pracSal, diag) if (IDs%id_tob > 0) call post_data(IDs%id_tob, potTemp(:,:,G%ke), diag, mask=G%mask2dT) + endif + endif + if (.NOT.tv%S_is_absS) then + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sob > 0) call post_data(IDs%id_sob, tv%S(:,:,G%ke), diag, mask=G%mask2dT) + else + ! Internal T&S variables are conservative temperature & absolute salinity, + ! so they need to converted to potential temperature and practical salinity + ! for some diagnostics using TEOS-10 function calls. + if ((IDs%id_Sprac > 0) .or. (IDs%id_sob > 0)) then + do k=1,nz ; do j=js,je ; do i=is,ie + pracSal(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) + enddo; enddo ; enddo + if (IDs%id_Sprac > 0) call post_data(IDs%id_Sprac, pracSal, diag) if (IDs%id_sob > 0) call post_data(IDs%id_sob, pracSal(:,:,G%ke), diag, mask=G%mask2dT) endif endif @@ -2665,18 +2676,17 @@ subroutine post_diags_TS_vardec(G, CS, IDs, diag, dt) end subroutine post_diags_TS_vardec !> This routine posts diagnostics of various integrated quantities. -subroutine post_integrated_diagnostics(CS, IDs, G, GV, diag, dt_int, tv, ssh, fluxes) - type(MOM_control_struct), intent(in) :: CS !< control structure +subroutine post_integrated_diagnostics(IDs, G, GV, diag, dt_int, tv, ssh, fluxes) type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - real, intent(in) :: dt_int !< total time step associated with these diagnostics, in s. + real, intent(in) :: dt_int !< total time step associated with these diagnostics, in s. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ssh !< Time mean surface height without !! corrections for ice displacement(m) - type(forcing), intent(in) :: fluxes !< pointers to forcing fields + type(forcing), intent(in) :: fluxes !< pointers to forcing fields real, allocatable, dimension(:,:) :: & tmp, & ! temporary 2d field @@ -2794,12 +2804,12 @@ subroutine post_integrated_diagnostics(CS, IDs, G, GV, diag, dt_int, tv, ssh, fl end subroutine post_integrated_diagnostics !> This routine posts diagnostics of various ocean surface quantities. -subroutine post_surface_diagnostics(CS, IDs, G, diag, sfc_state) - type(MOM_control_struct), intent(in) :: CS !< control structure +subroutine post_surface_diagnostics(IDs, G, diag, sfc_state, tv) type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output type(surface), intent(in) :: sfc_state !< ocean surface state + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, dimension(SZI_(G),SZJ_(G)) :: & potTemp, & ! TEOS10 potential temperature (deg C) @@ -2812,22 +2822,30 @@ subroutine post_surface_diagnostics(CS, IDs, G, diag, sfc_state) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (.NOT.CS%use_conT_absS) then - !Internal T&S variables are assumed to be potential&practical + if (.NOT.tv%T_is_conT) then + ! Internal T&S variables are potential temperature & practical salinity if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) - if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) else - !Internal T&S variables are assumed to be conservative&absolute + ! Internal T&S variables are conservative temperature & absolute salinity if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) - if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) - !Using TEOS-10 function calls convert T&S diagnostics - !from conservative temp to potential temp and - !from absolute salinity to practical salinity + ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp + ! to potential temperature. do j=js,je ; do i=is,ie - pracSal(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) potTemp(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j),sfc_state%SST(i,j)) enddo ; enddo if (IDs%id_sst > 0) call post_data(IDs%id_sst, potTemp, diag, mask=G%mask2dT) + endif + if (.NOT.tv%S_is_absS) then + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) + else + ! Internal T&S variables are conservative temperature & absolute salinity + if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) + ! Use TEOS-10 function calls convert T&S diagnostics from absolute salinity + ! to practical salinity. + do j=js,je ; do i=is,ie + pracSal(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) + enddo ; enddo if (IDs%id_sss > 0) call post_data(IDs%id_sss, pracSal, diag, mask=G%mask2dT) endif @@ -3220,6 +3238,8 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) sfc_state%frazil => CS%tv%frazil sfc_state%TempxPmE => CS%tv%TempxPmE sfc_state%internal_heat => CS%tv%internal_heat + sfc_state%T_is_conT = CS%tv%T_is_conT + sfc_state%S_is_absS = CS%tv%S_is_absS if (associated(CS%visc%taux_shelf)) sfc_state%taux_shelf => CS%visc%taux_shelf if (associated(CS%visc%tauy_shelf)) sfc_state%tauy_shelf => CS%visc%tauy_shelf From c9af68ef4a4b46561e59fae7e1802a74928669f6 Mon Sep 17 00:00:00 2001 From: Brandon Reichl Date: Mon, 8 Jan 2018 13:35:52 -0500 Subject: [PATCH 097/170] Change logic in MOM_energetic_PBL.F90 to avoid divide by 0 when u_star_mean is 0. --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 6b1c14fdf7..25b018e734 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1971,9 +1971,9 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) real :: z0, z0i, r1, r2, r3, r4, tmp, us_sl, lasl_sqr_i real :: pi, u10 pi = 4.0*atan(1.0) - ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/1.225),U10,GV) - if (u10 .gt. 0.0 .and. ustar .gt. 0.0) then + if (ustar .gt. 0.0) then + ! Computing u10 based on u_star and COARE 3.5 relationships + call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/1.225),U10,GV) ! surface Stokes drift us = us_to_u10*u10 ! From 52f71ef89afe7c05a3378ce43ac3e44e79915a69 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 9 Jan 2018 16:01:34 -0900 Subject: [PATCH 098/170] Obsoleting EXTEND_OBC_SEGMENTS. It's time to make it go away. --- src/core/MOM_open_boundary.F90 | 54 ++++++++++++------------- src/diagnostics/MOM_obsolete_params.F90 | 2 + 2 files changed, 29 insertions(+), 27 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 07dd1d6f91..b05bebb87b 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -181,7 +181,7 @@ module MOM_open_boundary !! in the strain on open boundaries. logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for !! use in the biharmonic viscosity term. - logical :: extend_segments = .false. !< If True, extend OBC segments (for testing) +! logical :: extend_segments = .false. !< If True, extend OBC segments (for testing) logical :: brushcutter_mode = .false. !< If True, read data on supergrid. real :: g_Earth ! Properties of the segments used. @@ -280,10 +280,10 @@ subroutine open_boundary_config(G, param_file, OBC) if (config1 .ne. "none") OBC%user_BCs_set_globally = .true. - call get_param(param_file, mdl, "EXTEND_OBC_SEGMENTS", OBC%extend_segments, & - "If true, extend OBC segments. This option is used to recover\n"//& - "legacy solutions dependent on an incomplete implementaion of OBCs.\n"//& - "This option will be obsoleted in the future.", default=.false.) +! call get_param(param_file, mdl, "EXTEND_OBC_SEGMENTS", OBC%extend_segments, & +! "If true, extend OBC segments. This option is used to recover\n"//& +! "legacy solutions dependent on an incomplete implementaion of OBCs.\n"//& +! "This option will be obsoleted in the future.", default=.false.) if (OBC%number_of_segments > 0) then call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & @@ -676,13 +676,13 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile ! Hack to extend segment by one point - if (OBC%extend_segments) then - if (Js_obcJs_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_E @@ -738,10 +738,10 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) OBC%segment(l_seg)%specified = .true. OBC%specified_u_BCs_exist_globally = .true. ! This avoids deallocation ! Hack to undo the hack above for SIMPLE BCs - if (OBC%extend_segments) then - Js_obc = Js_obc + 1 - Je_obc = Je_obc - 1 - endif +! if (OBC%extend_segments) then +! Js_obc = Js_obc + 1 +! Je_obc = Je_obc - 1 +! endif else call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") @@ -789,13 +789,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) Ie_obc = Ie_obc - G%idg_offset ! Convert to local tile indices on this tile ! Hack to extend segment by one point - if (OBC%extend_segments) then - if (Is_obcIs_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_S @@ -841,10 +841,10 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) OBC%segment(l_seg)%specified = .true. OBC%specified_v_BCs_exist_globally = .true. ! This avoids deallocation ! Hack to undo the hack above for SIMPLE BCs - if (OBC%extend_segments) then - Is_obc = Is_obc + 1 - Ie_obc = Ie_obc - 1 - endif +! if (OBC%extend_segments) then +! Is_obc = Is_obc + 1 +! Ie_obc = Ie_obc - 1 +! endif else call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index a673ec9aff..df906c79ab 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -66,6 +66,8 @@ subroutine find_obsolete_params(param_file) hint="Instead use OBC_SEGMENT_XXX_DATA.") call obsolete_char(param_file, "READ_OBC_TS", & hint="Instead use OBC_SEGMENT_XXX_DATA.") + call obsolete_char(param_file, "EXTEND_OBC_SEGMENTS", & + hint="This option is no longer needed, nor supported.") test_logic3 = .true. ; call read_param(param_file,"ENABLE_THERMODYNAMICS",test_logic3) test_logic = .true. ; call read_param(param_file,"TEMPERATURE",test_logic) From cbd759a01ea57ccd437af2ddb358210d85948ed5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 9 Jan 2018 20:01:48 -0500 Subject: [PATCH 099/170] +Move register_Z_tracer to tracer registry Move register_Z_tracer into register_tracer_diagnostics for all tracers that use registry_diags, which already includes temperature and salinity. This change requires the addition of new diag_to_Z_CS argument for register tracer_diagnostics. All answers are bitwise identical. --- src/core/MOM.F90 | 17 +++-------------- src/tracer/MOM_tracer_registry.F90 | 15 ++++++++++++--- 2 files changed, 15 insertions(+), 17 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a8157cc543..7262fc3b94 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2184,25 +2184,14 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call lock_tracer_registry(CS%tracer_Reg) call callTree_waypoint("tracer registry now locked (initialize_MOM)") - ! now register some diagnostics since tracer registry is locked + ! now register some diagnostics since the tracer registry is now locked call register_diags(Time, G, GV, CS%IDs, CS%diag, CS%tv%C_p, CS%missing, CS%tv) - call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV) + call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & + CS%diag_to_Z_CSp) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, diag, CS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) endif - ! If need a diagnostic field, then would have been allocated in register_diags. - if (CS%use_temperature) then - call register_Z_tracer(CS%tv%T, "temp", "Potential Temperature", "degC", Time, & - G, CS%diag_to_Z_CSp, cmor_field_name="thetao", & - cmor_standard_name="sea_water_potential_temperature", & - cmor_long_name ="Sea Water Potential Temperature") - call register_Z_tracer(CS%tv%S, "salt", "Salinity", "psu", Time, & - G, CS%diag_to_Z_CSp, cmor_field_name="so", & - cmor_standard_name="sea_water_salinity", & - cmor_long_name ="Sea Water Salinity") - endif - ! This subroutine initializes any tracer packages. new_sim = is_new_run(CS%restart_CSp) call tracer_flow_control_init(.not.new_sim, Time, G, GV, CS%h, param_file, & diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index d03faf0205..6ec2c89d0f 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -10,6 +10,7 @@ module MOM_tracer_registry use MOM_coms, only : reproducing_sum use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data, safe_alloc_ptr +use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS 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_hor_index, only : hor_index_type @@ -327,7 +328,7 @@ end subroutine add_tracer_diagnostics !> register_tracer_diagnostics does a set of register_diag_field calls for any previously !! registered in a tracer registry with a value of registry_diags set to .true. -subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV) +subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry @@ -335,6 +336,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV) intent(in) :: h !< Layer thicknesses type(time_type), intent(in) :: Time !< current model time type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. character(len=24) :: name ! A variable's name in a NetCDF file. character(len=24) :: shortnm ! A shortened version of a variable's name for @@ -368,6 +371,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV) caller="register_tracer_diagnostics") shortnm = Tr%flux_nameroot flux_longname = Tr%flux_longname + if (len_trim(cmor_longname) == 0) cmor_longname = longname if (len_trim(Tr%flux_units) > 0) then ; flux_units = Tr%flux_units elseif (GV%Boussinesq) then ; flux_units = trim(units)//" m3 s-1" @@ -490,8 +494,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV) enddo ; enddo ; enddo endif -! call register_Z_tracer(Tr%t, name, longname, units, & -! Time, G, diag_to_Z_CSp) + if (len_trim(cmorname) == 0) then + call register_Z_tracer(Tr%t, name, longname, units, Time, G, diag_to_Z_CSp) + else + call register_Z_tracer(Tr%t, name, longname, units, Time, G, diag_to_Z_CSp, & + cmor_field_name=cmorname, cmor_standard_name=cmor_long_std(cmor_longname), & + cmor_long_name=cmor_longname) + endif endif ; enddo end subroutine register_tracer_diagnostics From d95bd1235896b311edaf4d59afbc2af651092465 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 9 Jan 2018 20:02:26 -0500 Subject: [PATCH 100/170] Use registry_diags for OCMIP2_CFC Simplified the OCMIP2_CFC tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/MOM_OCMIP2_CFC.F90 | 109 ++++------------------------------ 1 file changed, 12 insertions(+), 97 deletions(-) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index cd81541ada..7c590ffb5a 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -47,7 +47,6 @@ module MOM_OCMIP2_CFC !* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -61,7 +60,7 @@ module MOM_OCMIP2_CFC use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_variables, only : surface @@ -83,10 +82,6 @@ module MOM_OCMIP2_CFC ! NTR is the number of tracers in this module. integer, parameter :: NTR = 2 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: OCMIP2_CFC_CS ; private character(len=200) :: IC_file ! The file in which the CFC initial values can ! be found, or an empty string for internal initilaization. @@ -106,11 +101,6 @@ module MOM_OCMIP2_CFC real :: e1_11, e2_11, e3_11 ! More coefficients in the calculation of real :: e1_12, e2_12, e3_12 ! the CFC11 and CFC12 solubilities, in ! units of PSU-1, PSU-1 K-1, PSU-1 K-2. - type(p3d), dimension(NTR) :: & - tr_adx, & ! Tracer zonal advective fluxes in mol s-1. - tr_ady, & ! Tracer meridional advective fluxes in mol s-1. - tr_dfx, & ! Tracer zonal diffusive fluxes in mol s-1. - tr_dfy ! Tracer meridional diffusive fluxes in mol s-1. real :: CFC11_IC_val = 0.0 ! The initial value assigned to CFC11. real :: CFC12_IC_val = 0.0 ! The initial value assigned to CFC12. real :: CFC11_land_val = -1.0 ! The values of CFC11 and CFC12 used where @@ -127,9 +117,6 @@ module MOM_OCMIP2_CFC type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() - integer :: id_CFC11, id_CFC12 - integer, dimension(NTR) :: id_tr_adx = -1, id_tr_ady = -1 - integer, dimension(NTR) :: id_tr_dfx = -1, id_tr_dfy = -1 ! The following vardesc types contain a package of metadata about each tracer. type(vardesc) :: CFC11_desc, CFC12_desc @@ -164,6 +151,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) real :: a11_dflt(4), a12_dflt(4) ! Default values of the various coefficients real :: d11_dflt(4), d12_dflt(4) ! In the expressions for the solubility and real :: e11_dflt(3), e12_dflt(3) ! Schmidt numbers. + character(len=48) :: flux_units ! The units for tracer fluxes. logical :: register_OCMIP2_CFC integer :: isd, ied, jsd, jed, nz, m @@ -216,6 +204,10 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%CFC11_desc = var_desc(CS%CFC11_name,"mol m-3","CFC-11 Concentration", caller=mdl) CS%CFC12_desc = var_desc(CS%CFC12_name,"mol m-3","CFC-12 Concentration", caller=mdl) + ! This needs to be changed if the units of tracer are changed above. + if (GV%Boussinesq) then ; flux_units = "mol s-1" + else ; flux_units = "mol m-3 kg s-1" ; endif + allocate(CS%CFC11(isd:ied,jsd:jed,nz)) ; CS%CFC11(:,:,:) = 0.0 allocate(CS%CFC12(isd:ied,jsd:jed,nz)) ; CS%CFC12(:,:,:) = 0.0 @@ -227,13 +219,15 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) .not.CS%tracers_may_reinit, restart_CS) ! Register CFC11 for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%CFC11_desc, param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%CFC11_desc) + tr_desc_ptr=CS%CFC11_desc, registry_diags=.true., & + flux_units=flux_units, diag_form=1) ! Do the same for CFC12 tr_ptr => CS%CFC12 call register_restart_field(tr_ptr, CS%CFC12_desc, & .not.CS%tracers_may_reinit, restart_CS) call register_tracer(tr_ptr, CS%CFC12_desc, param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%CFC12_desc) + tr_desc_ptr=CS%CFC12_desc, registry_diags=.true., & + flux_units=flux_units, diag_form=1) ! Set and read the various empirical coefficients. @@ -406,17 +400,8 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & ! (in/out) diag_to_Z_Csp - A pointer to the control structure for diagnostics ! in depth space. logical :: from_file = .false. - character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes. - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m - integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB CS%Time => day CS%diag => diag @@ -438,60 +423,8 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & ! call add_tracer_OBC_values(trim(CS%CFC12_desc%name), CS%tr_Reg, 0.0) endif - - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "mol s-1" - else ; flux_units = "mol m-3 kg s-1" ; endif - - do m=1,NTR - ! Register the tracer advective and diffusive fluxes for potential - ! diagnostic output. - if (m==1) then - ! Register CFC11 for potential diagnostic output. - call query_vardesc(CS%CFC11_desc, name, units=units, longname=longname, & - caller="initialize_OCMIP2_CFC") - CS%id_CFC11 = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - call register_Z_tracer(CS%CFC11, trim(name), longname, units, & - day, G, diag_to_Z_CSp) - elseif (m==2) then - ! Register CFC12 for potential diagnostic output. - call query_vardesc(CS%CFC12_desc, name, units=units, longname=longname, & - caller="initialize_OCMIP2_CFC") - CS%id_CFC12 = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - call register_Z_tracer(CS%CFC12, trim(name), longname, units, & - day, G, diag_to_Z_CSp) - else - call MOM_error(FATAL,"initialize_OCMIP2_CFC is only set up to work"//& - "with NTR <= 2.") - endif - - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - enddo - end subroutine initialize_OCMIP2_CFC + !>This subroutine initializes a tracer array. subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -634,19 +567,7 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS call tracer_vertdiff(h_old, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) endif - ! Write out any desired diagnostics. - if (CS%id_CFC11>0) call post_data(CS%id_CFC11, CFC11, CS%diag) - if (CS%id_CFC12>0) call post_data(CS%id_CFC12, CFC12, CS%diag) - do m=1,NTR - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo + ! Write out any desired diagnostics from tracer sources & sinks here. end subroutine OCMIP2_CFC_column_physics @@ -798,12 +719,6 @@ subroutine OCMIP2_CFC_end(CS) if (associated(CS)) then if (associated(CS%CFC11)) deallocate(CS%CFC11) if (associated(CS%CFC12)) deallocate(CS%CFC12) - do m=1,NTR - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo deallocate(CS) endif From 266eb4bbaa8cd487748d6e9ece25e9bc17d9e4f8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 9 Jan 2018 20:02:55 -0500 Subject: [PATCH 101/170] Use registry_diags for ideal_age_example Simplified the ideal_age_example tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/ideal_age_example.F90 | 80 ++------------------------------ 1 file changed, 4 insertions(+), 76 deletions(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 744026269c..4102c0e0e1 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -37,9 +37,8 @@ module ideal_age_example !* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -71,10 +70,6 @@ module ideal_age_example ! NTR_MAX is the maximum number of tracers in this module. integer, parameter :: NTR_MAX = 3 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: ideal_age_tracer_CS ; private integer :: ntr ! The number of tracers that are actually used. logical :: coupled_tracers = .false. ! These tracers are not offered to the @@ -88,11 +83,6 @@ module ideal_age_example type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR_MAX) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. real, dimension(NTR_MAX) :: & IC_val = 0.0, & ! The (uniform) initial condition value. young_val = 0.0, & ! The value assigned to tr at the surface. @@ -107,10 +97,8 @@ module ideal_age_example logical :: tracer_ages(NTR_MAX) integer, dimension(NTR_MAX) :: & - ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the + ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the ! surface tracer concentrations are to be provided to the coupler. - id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1, & - id_tr_dfx = -1, id_tr_dfy = -1 type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. @@ -237,7 +225,8 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) .not.CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + diag_form=1) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -348,47 +337,6 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! enddo endif - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "yr m3 s-1" - else ; flux_units = "yr kg s-1" ; endif - - do m=1,CS%ntr - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - cmor_field_name=cmorname, caller="initialize_ideal_age_tracer") - if (len_trim(cmorname)==0) then - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - else - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units), cmor_field_name=cmorname) - endif - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_ideal_age_tracer subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & @@ -478,19 +426,6 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo ; enddo ; enddo endif ; enddo - do m=1,CS%ntr - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine ideal_age_tracer_column_physics function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) @@ -586,13 +521,6 @@ subroutine ideal_age_example_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,CS%ntr - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine ideal_age_example_end From 57f3a7299fc9cc8bed387c2f66aa2bd910e6e5d6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:32:36 -0500 Subject: [PATCH 102/170] Use registry_diags for DOME_tracer Simplified the DOME_tracer tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/DOME_tracer.F90 | 78 ++++---------------------------------- 1 file changed, 7 insertions(+), 71 deletions(-) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 2cada3fd79..58a6c47cd0 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -2,9 +2,8 @@ module DOME_tracer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -34,10 +33,6 @@ module DOME_tracer ! ntr is the number of tracers in this module. integer, parameter :: ntr = 11 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: DOME_tracer_CS ; private logical :: coupled_tracers = .false. ! These tracers are not offered to the ! coupler. @@ -47,11 +42,6 @@ module DOME_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. @@ -61,8 +51,6 @@ module DOME_tracer type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. - integer, dimension(NTR) :: id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1 - integer, dimension(NTR) :: id_tr_dfx = -1, id_tr_dfy = -1 type(vardesc) :: tr_desc(NTR) end type DOME_tracer_CS @@ -85,6 +73,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "DOME_tracer" ! This module's name. + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. character(len=200) :: inputdir real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_DOME_tracer @@ -123,6 +113,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) else ; write(name,'("tr_D",I2.2)') m ; endif write(longname,'("Concentration of DOME Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. @@ -131,7 +123,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -304,43 +297,6 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & enddo endif - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" - else ; flux_units = "kg s-1" ; endif - - do m=1,NTR - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_DOME_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p, CS%tr_dfx(m)%p, CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_DOME_tracer !> This subroutine applies diapycnal diffusion and any other column @@ -395,19 +351,6 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, enddo endif - do m=1,NTR - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine DOME_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that @@ -450,13 +393,6 @@ subroutine DOME_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,NTR - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine DOME_tracer_end From e78e05bbbbda759af4494d344fcfc4911d08060b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:33:02 -0500 Subject: [PATCH 103/170] Use registry_diags for ISOMIP_tracer Simplified the ISOMIP_tracer tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/ISOMIP_tracer.F90 | 83 +++++------------------------------- 1 file changed, 10 insertions(+), 73 deletions(-) diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 07969696a0..44dc2a4276 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -10,14 +10,14 @@ module ISOMIP_tracer !********+*********+*********+*********+*********+*********+*********+** !* * -!* By Robert Hallberg, 2002 * -!* Adapted to the ISOMIP test case by Gustavo Marques, May 2016 * !* * +!* Original sample tracer package by Robert Hallberg, 2002 * +!* Adapted to the ISOMIP test case by Gustavo Marques, May 2016 * +!* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -49,10 +49,6 @@ module ISOMIP_tracer !< ntr is the number of tracers in this module. integer, parameter :: ntr = 1 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - !> tracer control structure type, public :: ISOMIP_tracer_CS ; private logical :: coupled_tracers = .false. !< These tracers are not offered to the @@ -63,11 +59,6 @@ module ISOMIP_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this !< subroutine, in g m-3? - type(p3d), dimension(NTR) :: & - tr_adx, &!< Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &!< Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &!< Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy !< Tracer meridional diffusive fluxes in g m-3 m3 s-1. real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. @@ -77,8 +68,6 @@ module ISOMIP_tracer type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !< timing of diagnostic output. - integer, dimension(NTR) :: id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1 - integer, dimension(NTR) :: id_tr_dfx = -1, id_tr_dfy = -1 type(vardesc) :: tr_desc(NTR) end type ISOMIP_tracer_CS @@ -101,6 +90,8 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, & #include "version_variable.h" character(len=40) :: mdl = "ISOMIP_tracer" ! This module's name. character(len=200) :: inputdir + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_ISOMIP_tracer integer :: isd, ied, jsd, jed, nz, m @@ -138,6 +129,8 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, & else ; write(name,'("tr_D",I2.2)') m ; endif write(longname,'("Concentration of ISOMIP Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. @@ -146,7 +139,8 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, & call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -255,43 +249,6 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! deallocate(temp) ! endif - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" - else ; flux_units = "kg s-1" ; endif - - do m=1,NTR - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_ISOMIP_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p, CS%tr_dfx(m)%p, CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_ISOMIP_tracer !> This subroutine applies diapycnal diffusion and any other column @@ -371,19 +328,6 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G enddo endif - do m=1,NTR - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine ISOMIP_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that @@ -425,13 +369,6 @@ subroutine ISOMIP_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,NTR - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine ISOMIP_tracer_end From a621c97a9dfeaa389994e44c4ac2aa5d2858ecff Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:33:27 -0500 Subject: [PATCH 104/170] Use registry_diags for advection_test_tracer Simplified the advection_test_tracer tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/advection_test_tracer.F90 | 81 ++++------------------------ 1 file changed, 9 insertions(+), 72 deletions(-) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 3d43c1197d..23b6164449 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -36,9 +36,8 @@ module advection_test_tracer !* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -69,12 +68,8 @@ module advection_test_tracer ! ntr is the number of tracers in this module. integer, parameter :: NTR = 11 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: advection_test_tracer_CS ; private - integer :: ntr = NTR ! Number of tracers in this module + integer :: ntr = NTR ! Number of tracers in this module logical :: coupled_tracers = .false. ! These tracers are not offered to the ! coupler. character(len=200) :: tracer_IC_file ! The full path to the IC file, or " " @@ -83,11 +78,6 @@ module advection_test_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. logical :: tracers_may_reinit @@ -103,9 +93,6 @@ module advection_test_tracer ! timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() - integer, dimension(NTR) :: id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1 - integer, dimension(NTR) :: id_tr_dfx = -1, id_tr_dfy = -1 - type(vardesc) :: tr_desc(NTR) end type advection_test_tracer_CS @@ -134,6 +121,8 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ #include "version_variable.h" character(len=40) :: mdl = "advection_test_tracer" ! This module's name. character(len=200) :: inputdir + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_advection_test_tracer integer :: isd, ied, jsd, jed, nz, m @@ -187,6 +176,9 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ else ; write(name,'("tr",I2.2)') m ; endif write(longname,'("Concentration of Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. @@ -196,7 +188,8 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ .not. CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -312,43 +305,6 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS enddo - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" - else ; flux_units = "kg s-1" ; endif - - do m=1,NTR - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_advection_test_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_advection_test_tracer @@ -407,18 +363,6 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, enddo endif - do m=1,NTR - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo end subroutine advection_test_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that @@ -513,13 +457,6 @@ subroutine advection_test_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,NTR - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine advection_test_tracer_end From 18f8dc65f7625a682bf68fe208c79b38a7802017 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:34:59 -0500 Subject: [PATCH 105/170] Use registry_diags for boundary_impulse_tracer Simplified the boundary_impulse_tracer tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/boundary_impulse_tracer.F90 | 86 +++----------------------- 1 file changed, 10 insertions(+), 76 deletions(-) diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index fde275b63a..c13b0957b4 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -3,9 +3,8 @@ module boundary_impulse_tracer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -38,10 +37,6 @@ module boundary_impulse_tracer ! NTR_MAX is the maximum number of tracers in this module. integer, parameter :: NTR_MAX = 1 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: boundary_impulse_tracer_CS ; private integer :: ntr=NTR_MAX ! The number of tracers that are actually used. logical :: coupled_tracers = .false. ! These tracers are not offered to the @@ -50,20 +45,11 @@ module boundary_impulse_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR_MAX) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1.An Error Has Occurred - - - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. logical :: tracers_may_reinit ! If true, boundary_impulse can be initialized if ! not found in restart file integer, dimension(NTR_MAX) :: & - ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the + ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the ! surface tracer concentrations are to be provided to the coupler. - id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1, & - id_tr_dfx = -1, id_tr_dfy = -1 integer :: nkml ! Number of layers in mixed layer real, dimension(NTR_MAX) :: land_val = -1.0 @@ -106,6 +92,8 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=3) :: name_tag ! String for creating identifying boundary_impulse + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() real, pointer :: rem_time_ptr => NULL() logical :: register_boundary_impulse_tracer @@ -139,8 +127,11 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar do m=1,CS%ntr ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. - CS%tr_desc(m) = var_desc(trim("boundary_impulse"), "kg", & + CS%tr_desc(m) = var_desc(trim("boundary_impulse"), "kg kg-1", & "Boundary impulse tracer", caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + tr_ptr => CS%tr(:,:,:,m) call query_vardesc(CS%tr_desc(m), name=var_name, caller="register_boundary_impulse_tracer") ! Register the tracer for the restart file. @@ -148,7 +139,8 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar .not. CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -239,43 +231,6 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, ! enddo endif - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "g salt/(m^2 s)" - else ; flux_units = "g salt/(m^2 s)" ; endif - - do m=1,CS%ntr - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_boundary_impulse_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_boundary_impulse_tracer ! Apply source or sink at boundary and do vertical diffusion @@ -359,20 +314,6 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, enddo - do m=1,1 - if (CS%id_tracer(m)>0) then - call post_data(CS%id_tracer(m), CS%tr(:,:,:,m), CS%diag) - endif ! CS%id_tracer(m)>0 - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine boundary_impulse_tracer_column_physics !> Calculate total inventory of tracer @@ -470,13 +411,6 @@ subroutine boundary_impulse_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,CS%ntr - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine boundary_impulse_tracer_end From eef8a4596299052bce40bf7747b751746e4a43b3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:35:31 -0500 Subject: [PATCH 106/170] Use registry_diags for dye_example Simplified the dye_example tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/dye_example.F90 | 91 ++------------------------------------ 1 file changed, 4 insertions(+), 87 deletions(-) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index da7439f6a8..a3ed80a2e0 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -2,9 +2,8 @@ module regional_dyes ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -34,10 +33,6 @@ module regional_dyes public dye_stock, regional_dyes_end -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: dye_tracer_CS ; private integer :: ntr ! The number of tracers that are actually used. logical :: coupled_tracers = .false. ! These tracers are not offered to the @@ -51,17 +46,10 @@ module regional_dyes type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), allocatable, dimension(:) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. integer, allocatable, dimension(:) :: & - ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the + ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the ! surface tracer concentrations are to be provided to the coupler. - id_tracer, id_tr_adx, id_tr_ady, & - id_tr_dfx, id_tr_dfy type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. @@ -115,24 +103,9 @@ function register_dye_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%dye_source_maxlat(CS%ntr), & CS%dye_source_mindepth(CS%ntr), & CS%dye_source_maxdepth(CS%ntr)) - allocate(CS%tr_adx(CS%ntr), & - CS%tr_ady(CS%ntr), & - CS%tr_dfx(CS%ntr), & - CS%tr_dfy(CS%ntr)) - allocate(CS%ind_tr(CS%ntr), & - CS%id_tracer(CS%ntr), & - CS%id_tr_adx(CS%ntr), & - CS%id_tr_ady(CS%ntr), & - CS%id_tr_dfx(CS%ntr), & - CS%id_tr_dfy(CS%ntr)) + allocate(CS%ind_tr(CS%ntr)) allocate(CS%tr_desc(CS%ntr)) - CS%id_tracer(:) = -1 - CS%id_tr_adx(:) = -1 - CS%id_tr_ady(:) = -1 - CS%id_tr_dfx(:) = -1 - CS%id_tr_dfy(:) = -1 - CS%dye_source_minlon(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MINLON", CS%dye_source_minlon, & "This is the starting longitude at which we start injecting dyes.", & @@ -181,8 +154,6 @@ function register_dye_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tr_desc(m) = var_desc(trim(var_name), "conc", trim(desc_name), caller=mdl) enddo - - allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 do m=1,CS%ntr @@ -196,7 +167,7 @@ function register_dye_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) .not.CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true.) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -269,39 +240,6 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C enddo; enddo enddo - do m=1,CS%ntr - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_dye_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,G%IsdB,G%IedB,G%jsd,G%jed,GV%ke) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,G%isd,G%ied,G%JsdB,G%JedB,GV%ke) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_dye_tracer !> This subroutine applies diapycnal diffusion and any other column @@ -381,20 +319,6 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS enddo; enddo enddo - - do m=1,CS%ntr - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine dye_tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, @@ -484,13 +408,6 @@ subroutine regional_dyes_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,CS%ntr - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine regional_dyes_end From 86b9afdbb2016ae1e710b988700689aaa4d16c92 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:36:30 -0500 Subject: [PATCH 107/170] Use registry_diags for dyed_obc_tracer Simplified the dyed_obc_tracer tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/dyed_obc_tracer.F90 | 96 ++++------------------------------ 1 file changed, 9 insertions(+), 87 deletions(-) diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 21c0a4009a..1d18777a26 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -2,9 +2,8 @@ module dyed_obc_tracer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -30,10 +29,6 @@ module dyed_obc_tracer public register_dyed_obc_tracer, initialize_dyed_obc_tracer public dyed_obc_tracer_column_physics, dyed_obc_tracer_end -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: dyed_obc_tracer_CS ; private integer :: ntr ! The number of tracers that are actually used. logical :: coupled_tracers = .false. ! These tracers are not offered to the @@ -44,17 +39,10 @@ module dyed_obc_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), allocatable, dimension(:) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. integer, allocatable, dimension(:) :: & - ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the + ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the ! surface tracer concentrations are to be provided to the coupler. - id_tracer, id_tr_adx, id_tr_ady, & - id_tr_dfx, id_tr_dfy type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. @@ -84,6 +72,8 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir character(len=48) :: var_name ! The variable's name. character(len=48) :: desc_name ! The variable's descriptor. + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_dyed_obc_tracer integer :: isd, ied, jsd, jed, nz, m @@ -101,24 +91,9 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & "The number of dye tracers in this run. Each tracer \n"//& "should have a separate boundary segment.", default=0) - allocate(CS%tr_adx(CS%ntr), & - CS%tr_ady(CS%ntr), & - CS%tr_dfx(CS%ntr), & - CS%tr_dfy(CS%ntr)) - allocate(CS%ind_tr(CS%ntr), & - CS%id_tracer(CS%ntr), & - CS%id_tr_adx(CS%ntr), & - CS%id_tr_ady(CS%ntr), & - CS%id_tr_dfx(CS%ntr), & - CS%id_tr_dfy(CS%ntr)) + allocate(CS%ind_tr(CS%ntr)) allocate(CS%tr_desc(CS%ntr)) - CS%id_tracer(:) = -1 - CS%id_tr_adx(:) = -1 - CS%id_tr_ady(:) = -1 - CS%id_tr_dfx(:) = -1 - CS%id_tr_dfy(:) = -1 - call get_param(param_file, mdl, "dyed_obc_TRACER_IC_FILE", CS%tracer_IC_file, & "The name of a file from which to read the initial \n"//& "conditions for the dyed_obc tracers, or blank to initialize \n"//& @@ -137,6 +112,8 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) write(name,'("dye_",I2.2)') m write(longname,'("Concentration of dyed_obc Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. @@ -145,7 +122,8 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -225,43 +203,6 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & endif endif ! restart - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" - else ; flux_units = "kg s-1" ; endif - - do m=1,CS%ntr - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_dyed_obc_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p, CS%tr_dfx(m)%p, CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_dyed_obc_tracer !> This subroutine applies diapycnal diffusion and any other column @@ -317,19 +258,6 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo endif - do m=1,CS%ntr - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine dyed_obc_tracer_column_physics !> Clean up memory allocations, if any. @@ -339,12 +267,6 @@ subroutine dyed_obc_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,CS%ntr - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo deallocate(CS) endif From 640055da6b3e8b1158b31c0876e7b42196449673 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:36:51 -0500 Subject: [PATCH 108/170] Use registry_diags for oil_tracer Simplified the oil_tracer tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/oil_tracer.F90 | 84 +++++---------------------------------- 1 file changed, 11 insertions(+), 73 deletions(-) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index bf372e842c..2c167c11d6 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -37,9 +37,8 @@ module oil_tracer !* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -72,10 +71,6 @@ module oil_tracer ! NTR_MAX is the maximum number of tracers in this module. integer, parameter :: NTR_MAX = 20 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: oil_tracer_CS ; private integer :: ntr ! The number of tracers that are actually used. logical :: coupled_tracers = .false. ! These tracers are not offered to the @@ -94,11 +89,6 @@ module oil_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR_MAX) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. real, dimension(NTR_MAX) :: & IC_val = 0.0, & ! The (uniform) initial condition value. young_val = 0.0, & ! The value assigned to tr at the surface. @@ -112,10 +102,8 @@ module oil_tracer ! initialization code if they are not found in the ! restart files. integer, dimension(NTR_MAX) :: & - ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the + ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the ! surface tracer concentrations are to be provided to the coupler. - id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1, & - id_tr_dfx = -1, id_tr_dfy = -1 type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. @@ -151,6 +139,8 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=3) :: name_tag ! String for creating identifying oils + character(len=48) :: flux_units ! The units for tracer fluxes, here + ! kg(oil) s-1 or kg(oil) m-3 kg(water) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_oil_tracer integer :: isd, ied, jsd, jed, nz, m, i, j @@ -215,7 +205,7 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) if (CS%oil_source_k(m)/=0) then write(name_tag(1:3),'("_",I2.2)') m CS%ntr = CS%ntr + 1 - CS%tr_desc(m) = var_desc("oil"//trim(name_tag), "kg/m3", "Oil Tracer", caller=mdl) + CS%tr_desc(m) = var_desc("oil"//trim(name_tag), "kg m-3", "Oil Tracer", caller=mdl) CS%IC_val(m) = 0.0 if (CS%oil_decay_days(m)>0.) then CS%oil_decay_rate(m)=1./(86400.0*CS%oil_decay_days(m)) @@ -226,6 +216,10 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) enddo call log_param(param_file, mdl, "OIL_DECAY_RATE", CS%oil_decay_rate(1:CS%ntr)) + ! This needs to be changed if the units of tracer are changed above. + if (GV%Boussinesq) then ; flux_units = "kg s-1" + else ; flux_units = "kg m-3 kg s-1" ; endif + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 do m=1,CS%ntr @@ -238,7 +232,8 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) .not.CS%oil_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -360,43 +355,6 @@ subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! enddo endif - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "yr m3 s-1" - else ; flux_units = "yr kg s-1" ; endif - - do m=1,CS%ntr - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_oil_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine initialize_oil_tracer subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, & @@ -506,19 +464,6 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS enddo endif - do m=1,CS%ntr - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine oil_tracer_column_physics function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) @@ -614,13 +559,6 @@ subroutine oil_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,CS%ntr - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine oil_tracer_end From ea02dbaa2cc8d236ba901ffbb6b0ff61a1c00e98 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:37:14 -0500 Subject: [PATCH 109/170] Use registry_diags for tracer_example Simplified the tracer_example tracer package by using the tracer registry for all of its diagnostics. All answers are bitwise identical. --- src/tracer/tracer_example.F90 | 80 ++++------------------------------- 1 file changed, 9 insertions(+), 71 deletions(-) diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index b39affa7ad..d88969be6b 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -33,9 +33,8 @@ module USER_tracer_example !* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -64,10 +63,6 @@ module USER_tracer_example ! NTR is the number of tracers in this module. integer, parameter :: NTR = 1 -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: USER_tracer_example_CS ; private logical :: coupled_tracers = .false. ! These tracers are not offered to the ! coupler. @@ -77,11 +72,6 @@ module USER_tracer_example type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. @@ -91,8 +81,6 @@ module USER_tracer_example type(diag_ctrl), pointer :: diag ! A pointer to a structure of shareable ! ocean diagnostic fields and control variables. - integer, dimension(NTR) :: id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1 - integer, dimension(NTR) :: id_tr_dfx = -1, id_tr_dfy = -1 type(vardesc) :: tr_desc(NTR) end type USER_tracer_example_CS @@ -118,6 +106,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS #include "version_variable.h" character(len=40) :: mdl = "tracer_example" ! This module's name. character(len=200) :: inputdir + character(len=48) :: flux_units ! The units for tracer fluxes, usually + ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: USER_register_tracer_example integer :: isd, ied, jsd, jed, nz, m @@ -155,6 +145,10 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS write(longname,'("Concentration of Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + ! This needs to be changed if the units of tracer are changed above. + if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" + else ; flux_units = "kg s-1" ; endif + ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) @@ -162,7 +156,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) + tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & + flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -309,43 +304,6 @@ subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & enddo endif - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" - else ; flux_units = "kg s-1" ; endif - - do m=1,NTR - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="USER_initialize_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo - end subroutine USER_initialize_tracer !> This subroutine applies diapycnal diffusion and any other column @@ -444,19 +402,6 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) enddo ; enddo ; enddo enddo - do m=1,NTR - if (CS%id_tracer(m)>0) & - call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - end subroutine tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, @@ -545,13 +490,6 @@ subroutine USER_tracer_example_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,NTR - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - deallocate(CS) endif end subroutine USER_tracer_example_end From 08da9be12af0d212007a9fc72ec17e671d5bbb15 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:37:40 -0500 Subject: [PATCH 110/170] Use registry_diags for pseudo_salt_tracer Simplified the pseudo_salt_tracer tracer package by using the tracer registry for all of its diagnostics. Also reconded estensive portions of this module to reflect the fact that it uses only a single tracer, which is now called "ps", and to avoid unnecessary use of extra memory. All answers are bitwise identical. --- src/tracer/pseudo_salt_tracer.F90 | 223 ++++++++---------------------- 1 file changed, 59 insertions(+), 164 deletions(-) diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index ce847fb3bc..2328b56934 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -38,7 +38,7 @@ module pseudo_salt_tracer use MOM_debugging, only : hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -68,43 +68,22 @@ module pseudo_salt_tracer public pseudo_salt_tracer_column_physics, pseudo_salt_tracer_surface_state public pseudo_salt_stock, pseudo_salt_tracer_end -! NTR_MAX is the maximum number of tracers in this module. -integer, parameter :: NTR_MAX = 1 - -type p3d - real, dimension(:,:,:), pointer :: p => NULL() -end type p3d - type, public :: pseudo_salt_tracer_CS ; private - integer :: ntr=NTR_MAX ! The number of tracers that are actually used. - logical :: coupled_tracers = .false. ! These tracers are not offered to the - ! coupler. type(time_type), pointer :: Time ! A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - real, pointer :: diff(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - type(p3d), dimension(NTR_MAX) :: & - tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1.An Error Has Occurred - - - tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. - tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. - tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. + real, pointer :: ps(:,:,:) => NULL() ! The array of pseudo-salt tracer used in this + ! subroutine, in psu + real, pointer :: diff(:,:,:) => NULL() ! The difference between the pseudo-salt + ! tracer and the real salt, in psu. logical :: pseudo_salt_may_reinit = .true. ! Hard coding since this should not matter - integer, dimension(NTR_MAX) :: & - ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the - ! surface tracer concentrations are to be provided to the coupler. - id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1, & - id_tr_dfx = -1, id_tr_dfy = -1 - real, dimension(NTR_MAX) :: land_val = -1.0 + + integer :: id_psd = -1 type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(vardesc) :: tr_desc(NTR_MAX) + type(vardesc) :: tr_desc end type pseudo_salt_tracer_CS contains @@ -136,7 +115,7 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=3) :: name_tag ! String for creating identifying pseudo_salt real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_pseudo_salt_tracer - integer :: isd, ied, jsd, jed, nz, m, i, j + integer :: isd, ied, jsd, jed, nz, i, j isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then @@ -149,31 +128,20 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") - CS%ntr = NTR_MAX - allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 - allocate(CS%diff(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%diff(:,:,:,:) = 0.0 - - do m=1,CS%ntr - ! This is needed to force the compiler not to do a copy in the registration - ! calls. Curses on the designers and implementers of Fortran90. - CS%tr_desc(m) = var_desc(trim("pseudo_salt_diff"), "kg", & - "Difference between pseudo salt passive tracer and salt tracer", caller=mdl) - tr_ptr => CS%tr(:,:,:,m) - call query_vardesc(CS%tr_desc(m), name=var_name, caller="register_pseudo_salt_tracer") - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), & - .not. CS%pseudo_salt_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m)) - - ! Set coupled_tracers to be true (hard-coded above) to provide the surface - ! values to the coupler (if any). This is meta-code and its arguments will - ! currently (deliberately) give fatal errors if it is used. - if (CS%coupled_tracers) & - CS%ind_tr(m) = aof_set_coupler_flux(trim(var_name)//'_flux', & - flux_type=' ', implementation=' ', caller="register_pseudo_salt_tracer") - enddo + allocate(CS%ps(isd:ied,jsd:jed,nz)) ; CS%ps(:,:,:) = 0.0 + allocate(CS%diff(isd:ied,jsd:jed,nz)) ; CS%diff(:,:,:) = 0.0 + + CS%tr_desc = var_desc(trim("pseudo_salt"), "psu", & + "Pseudo salt passive tracer", caller=mdl) + + tr_ptr => CS%ps(:,:,:) + call query_vardesc(CS%tr_desc, name=var_name, caller="register_pseudo_salt_tracer") + ! Register the tracer for the restart file. + call register_restart_field(tr_ptr, CS%tr_desc, & + .not. CS%pseudo_salt_may_reinit, restart_CS) + ! Register the tracer for horizontal advection & diffusion. + call register_tracer(tr_ptr, CS%tr_desc, param_file, HI, GV, tr_Reg, & + tr_desc_ptr=CS%tr_desc, registry_diags=.true.) CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS @@ -194,8 +162,7 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, type(sponge_CS), pointer :: sponge_CSp type(diag_to_Z_CS), pointer :: diag_to_Z_CSp type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables -! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) -! and it sets up the tracer output. +! This subroutine initializes the tracer fields in CS%ps(:,:,:). ! Arguments: restart - .true. if the fields have already been read from ! a restart file. @@ -218,11 +185,12 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, character(len=48) :: flux_units ! The units for age tracer fluxes, either ! years m3 s-1 or years kg s-1. logical :: OK - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return - if (CS%ntr < 1) return + if (.not.associated(CS%diff)) return + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -231,60 +199,21 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, CS%diag => diag name = "pseudo_salt" - do m=1,CS%ntr - call query_vardesc(CS%tr_desc(m), name=name, caller="initialize_pseudo_salt_tracer") - if ((.not.restart) .or. (.not. & - query_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp))) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - CS%tr(i,j,k,m) = tv%S(i,j,k) - enddo ; enddo ; enddo - endif - enddo ! Tracer loop + call query_vardesc(CS%tr_desc, name=name, caller="initialize_pseudo_salt_tracer") + if ((.not.restart) .or. (.not.query_initialized(CS%ps, name, CS%restart_CSp))) then + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%ps(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif if (associated(OBC)) then ! All tracers but the first have 0 concentration in their inflows. As this ! is the default value, the following calls are unnecessary. - ! do m=1,CS%ntr - ! call add_tracer_OBC_values(trim(CS%tr_desc(m)%name), CS%tr_Reg, 0.0) - ! enddo + ! call add_tracer_OBC_values(trim(CS%tr_desc%name), CS%tr_Reg, 0.0) endif - ! This needs to be changed if the units of tracer are changed above. - if (GV%Boussinesq) then ; flux_units = "g salt/(m^2 s)" - else ; flux_units = "g salt/(m^2 s)" ; endif - - do m=1,CS%ntr - ! Register the tracer for the restart file. - call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & - caller="initialize_pseudo_salt_tracer") - CS%id_tracer(m) = register_diag_field("ocean_model", trim(name), CS%diag%axesTL, & - day, trim(longname) , trim(units)) - CS%id_tr_adx(m) = register_diag_field("ocean_model", trim(name)//"_adx", & - CS%diag%axesCuL, day, trim(longname)//" advective zonal flux" , & - trim(flux_units)) - CS%id_tr_ady(m) = register_diag_field("ocean_model", trim(name)//"_ady", & - CS%diag%axesCvL, day, trim(longname)//" advective meridional flux" , & - trim(flux_units)) - CS%id_tr_dfx(m) = register_diag_field("ocean_model", trim(name)//"_dfx", & - CS%diag%axesCuL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - CS%id_tr_dfy(m) = register_diag_field("ocean_model", trim(name)//"_dfy", & - CS%diag%axesCvL, day, trim(longname)//" diffusive zonal flux" , & - trim(flux_units)) - if (CS%id_tr_adx(m) > 0) call safe_alloc_ptr(CS%tr_adx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_ady(m) > 0) call safe_alloc_ptr(CS%tr_ady(m)%p,isd,ied,JsdB,JedB,nz) - if (CS%id_tr_dfx(m) > 0) call safe_alloc_ptr(CS%tr_dfx(m)%p,IsdB,IedB,jsd,jed,nz) - if (CS%id_tr_dfy(m) > 0) call safe_alloc_ptr(CS%tr_dfy(m)%p,isd,ied,JsdB,JedB,nz) - -! Register the tracer for horizontal advection & diffusion. - if ((CS%id_tr_adx(m) > 0) .or. (CS%id_tr_ady(m) > 0) .or. & - (CS%id_tr_dfx(m) > 0) .or. (CS%id_tr_dfy(m) > 0)) & - call add_tracer_diagnostics(name, CS%tr_Reg, CS%tr_adx(m)%p, & - CS%tr_ady(m)%p,CS%tr_dfx(m)%p,CS%tr_dfy(m)%p) - - call register_Z_tracer(CS%tr(:,:,:,m), trim(name), longname, units, & - day, G, diag_to_Z_CSp) - enddo + CS%id_psd = register_diag_field("ocean_model", "pseudo_salt_diff", CS%diag%axesTL, & + day, "Difference between pseudo salt passive tracer and salt tracer", "psu") end subroutine initialize_pseudo_salt_tracer @@ -333,7 +262,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G real :: Isecs_per_year = 1.0 / (365.0*86400.0) real :: year, h_total, scale, htot, Ih_limit integer :: secs, days - integer :: i, j, k, is, ie, js, je, nz, m, k_max + integer :: i, j, k, is, ie, js, je, nz, k_max real, allocatable :: local_tr(:,:,:) real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified real, dimension(:,:), pointer :: net_salt @@ -342,11 +271,11 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G net_salt=>fluxes%netSalt if (.not.associated(CS)) return - if (CS%ntr < 1) return + if (.not.associated(CS%diff)) return if (debug) then call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI) - call hchksum(CS%tr(:,:,:,1),"pseudo_salt pre pseudo-salt vertdiff", G%HI) + call hchksum(CS%ps,"pseudo_salt pre pseudo-salt vertdiff", G%HI) endif ! This uses applyTracerBoundaryFluxesInOut, usually in ALE mode @@ -354,40 +283,23 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo; - call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,1), dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth, out_flux_optional=net_salt) - call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) + call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) else - call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) + call tracer_vertdiff(h_old, ea, eb, dt, CS%ps, G, GV) endif do k=1,nz ; do j=js,je ; do i=is,ie - CS%diff(i,j,k,1) = CS%tr(i,j,k,1)-tv%S(i,j,k) + CS%diff(i,j,k) = CS%ps(i,j,k)-tv%S(i,j,k) enddo ; enddo ; enddo if(debug) then call hchksum(tv%S,"salt post pseudo-salt vertdiff", G%HI) - call hchksum(CS%tr(:,:,:,1),"pseudo_salt post pseudo-salt vertdiff", G%HI) + call hchksum(CS%ps,"pseudo_salt post pseudo-salt vertdiff", G%HI) endif - allocate(local_tr(G%isd:G%ied,G%jsd:G%jed,nz)) - do m=1,1 - if (CS%id_tracer(m)>0) then - do k=1,nz ; do j=js,je ; do i=is,ie - local_tr(i,j,k) = CS%tr(i,j,k,m)-tv%S(i,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_tracer(m),local_tr,CS%diag) - endif ! CS%id_tracer(m)>0 - if (CS%id_tr_adx(m)>0) & - call post_data(CS%id_tr_adx(m),CS%tr_adx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_ady(m)>0) & - call post_data(CS%id_tr_ady(m),CS%tr_ady(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfx(m)>0) & - call post_data(CS%id_tr_dfx(m),CS%tr_dfx(m)%p(:,:,:),CS%diag) - if (CS%id_tr_dfy(m)>0) & - call post_data(CS%id_tr_dfy(m),CS%tr_dfy(m)%p(:,:,:),CS%diag) - enddo - deallocate(local_tr) + if (CS%id_psd>0) call post_data(CS%id_psd, CS%diff, CS%diag) end subroutine pseudo_salt_tracer_column_physics @@ -417,12 +329,12 @@ function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) ! (in,opt) stock_index - the coded index of a specific stock being sought. ! Return value: the number of stocks calculated here. - integer :: i, j, k, is, ie, js, je, nz, m + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pseudo_salt_stock = 0 if (.not.associated(CS)) return - if (CS%ntr < 1) return + if (.not.associated(CS%diff)) return if (present(stock_index)) then ; if (stock_index > 0) then ! Check whether this stock is available from this routine. @@ -431,18 +343,16 @@ function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif - do m=1,1 - call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="pseudo_salt_stock") - units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%diff(i,j,k,m) * & - (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = GV%H_to_kg_m2 * stocks(m) - enddo + call query_vardesc(CS%tr_desc, name=names(1), units=units(1), caller="pseudo_salt_stock") + units(1) = trim(units(1))//" kg" + stocks(1) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + stocks(1) = stocks(1) + CS%diff(i,j,k) * & + (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) + enddo ; enddo ; enddo + stocks(1) = GV%H_to_kg_m2 * stocks(1) - pseudo_salt_stock = CS%ntr + pseudo_salt_stock = 1 end function pseudo_salt_stock @@ -467,15 +377,7 @@ subroutine pseudo_salt_tracer_surface_state(state, h, G, CS) if (.not.associated(CS)) return - if (CS%coupled_tracers) then - do m=1,CS%ntr - ! This call loads the surface values into the appropriate array in the - ! coupler-type structure. - call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & - jdim=(/jsd, js, je, jed/) ) - enddo - endif + ! By design, this tracer package does not return any surface states. end subroutine pseudo_salt_tracer_surface_state @@ -484,15 +386,8 @@ subroutine pseudo_salt_tracer_end(CS) integer :: m if (associated(CS)) then - if (associated(CS%tr)) deallocate(CS%tr) - if (associated(CS%tr)) deallocate(CS%diff) - do m=1,CS%ntr - if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) - if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) - if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) - if (associated(CS%tr_dfy(m)%p)) deallocate(CS%tr_dfy(m)%p) - enddo - + if (associated(CS%ps)) deallocate(CS%ps) + if (associated(CS%diff)) deallocate(CS%diff) deallocate(CS) endif end subroutine pseudo_salt_tracer_end From e234410a4c38c188bad41e18704a9602789bdcac Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 15:38:24 -0500 Subject: [PATCH 111/170] Further code cleanup of OCMIP2_CFC Corrected some comments and avoid an unused module use statement in the OCMIP2_CFC tracer package. All answers are bitwise identical. --- src/tracer/MOM_OCMIP2_CFC.F90 | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 7c590ffb5a..82e3fe11eb 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -36,9 +36,9 @@ module MOM_OCMIP2_CFC !* A small fragment of the horizontal grid is shown below: * !* * !* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tr_ady, tr_dfy * -!* j x ^ x ^ x At >: u, tr_adx, tr_dfx * -!* j > o > o > At o: h, tr, CFC11, CFC12 * +!* j+1 > o > o > At ^: v, * +!* j x ^ x ^ x At >: u * +!* j > o > o > At o: h, CFC11, CFC12 * !* j-1 x ^ x ^ x * !* i-1 i i+1 At x & ^: * !* i i+1 At > & o: * @@ -48,7 +48,7 @@ module MOM_OCMIP2_CFC !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_diag_to_Z, only : diag_to_Z_CS use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -203,8 +203,6 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%CFC11_name = "CFC11" ; CS%CFC12_name = "CFC12" CS%CFC11_desc = var_desc(CS%CFC11_name,"mol m-3","CFC-11 Concentration", caller=mdl) CS%CFC12_desc = var_desc(CS%CFC12_name,"mol m-3","CFC-12 Concentration", caller=mdl) - - ! This needs to be changed if the units of tracer are changed above. if (GV%Boussinesq) then ; flux_units = "mol s-1" else ; flux_units = "mol m-3 kg s-1" ; endif @@ -220,14 +218,14 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Register CFC11 for horizontal advection & diffusion. call register_tracer(tr_ptr, CS%CFC11_desc, param_file, HI, GV, tr_Reg, & tr_desc_ptr=CS%CFC11_desc, registry_diags=.true., & - flux_units=flux_units, diag_form=1) + flux_units=flux_units) ! Do the same for CFC12 tr_ptr => CS%CFC12 call register_restart_field(tr_ptr, CS%CFC12_desc, & .not.CS%tracers_may_reinit, restart_CS) call register_tracer(tr_ptr, CS%CFC12_desc, param_file, HI, GV, tr_Reg, & tr_desc_ptr=CS%CFC12_desc, registry_diags=.true., & - flux_units=flux_units, diag_form=1) + flux_units=flux_units) ! Set and read the various empirical coefficients. From 303acd1b2dbfae7bc5d007d2b4dcb182f8cfb7b6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2018 22:20:31 -0500 Subject: [PATCH 112/170] Created kappa_shear_column subroutine Recast the main iterative driver of kappa-shear into a separately callable column function. This changses internal interfaces, but does not yet change external interfaces. All answers are bitwise identical. --- .../vertical/MOM_kappa_shear.F90 | 1081 +++++++++-------- 1 file changed, 561 insertions(+), 520 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 98b3d8f0fe..463c5fca57 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -104,29 +104,29 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kv_io, dt, G, GV, CS, initialize_all) 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(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u_in !< Initial zonal velocity, in m s-1. (Intent in) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: v_in !< Initial meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface in Pa !! (or NULL). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface !! (not layer!) in m2 s-1. Initially this is the !! value from the previous timestep, which may !! accelerate the iteration toward convergence. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: tke_io !< The turbulent kinetic energy per unit mass at !! each interface (not layer!) in m2 s-2. !! Initially this is the value from the previous !! timestep, which may accelerate the iteration !! toward convergence. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kv_io !< The vertical viscosity at each interface !! (not layer!) in m2 s-1. This discards any !! previous value i.e. intent(out) and simply @@ -164,12 +164,12 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! kappa_shear_init. ! (in,opt) initialize_all - If present and false, the previous value of ! kappa is used to start the iterations. - real, dimension(SZI_(G),SZK_(G)) :: & + real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-D version of h, but converted to m. u_2d, v_2d, T_2d, S_2d, rho_2d ! 2-D versions of u_in, v_in, T, S, and rho. - real, dimension(SZI_(G),SZK_(G)+1) :: & + real, dimension(SZI_(G),SZK_(GV)+1) :: & kappa_2d, tke_2d ! 2-D versions of various kappa_io and tke_io. - real, dimension(SZK_(G)) :: & + real, dimension(SZK_(GV)) :: & u, & ! The zonal velocity after a timestep of mixing, in m s-1. v, & ! The meridional velocity after a timestep of mixing, in m s-1. Idz, & ! The inverse of the distance between TKE points, in m. @@ -179,176 +179,86 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & u0xdz, & ! The initial zonal velocity times dz, in m2 s-1. v0xdz, & ! The initial meridional velocity times dz, in m2 s-1. T0xdz, & ! The initial temperature times dz, in C m. - S0xdz, & ! The initial salinity times dz, in PSU m. - u_test, v_test, T_test, S_test - real, dimension(SZK_(G)+1) :: & - N2, & ! The squared buoyancy frequency at an interface, in s-2. - dz_Int, & ! The extent of a finite-volume space surrounding an interface, - ! as used in calculating kappa and TKE, in m. - I_dz_int, & ! The inverse of the distance between velocity & density points - ! above and below an interface, in m-1. This is used to - ! calculate N2, shear, and fluxes, and it might differ from - ! 1/dz_Int, as they have different uses. - S2, & ! The squared shear at an interface, in s-2. - a1, & ! a1 is the coupling between adjacent interfaces in the TKE, - ! velocity, and density equations, in m s-1 or m. - c1, & ! c1 is used in the tridiagonal (and similar) solvers. - k_src, & ! The shear-dependent source term in the kappa equation, in s-1. - kappa_src, & ! The shear-dependent source term in the kappa equation in s-1. + S0xdz ! The initial salinity times dz, in PSU m. + real, dimension(SZK_(GV)+1) :: & kappa, & ! The shear-driven diapycnal diffusivity at an interface, in ! units of m2 s-1. tke, & ! The Turbulent Kinetic Energy per unit mass at an interface, ! in units of m2 s-2. kappa_avg, & ! The time-weighted average of kappa, in m2 s-1. - tke_avg, & ! The time-weighted average of TKE, in m2 s-2. - kappa_out, & ! The kappa that results from the kappa equation, in m2 s-1. - kappa_mid, & ! The average of the initial and predictor estimates of kappa, - ! in units of m2 s-1. - tke_pred, & ! The value of TKE from a predictor step, in m2 s-2. - kappa_pred, & ! The value of kappa from a predictor step, in m2 s-1. - pressure, & ! The pressure at an interface, in Pa. - T_int, & ! The temperature interpolated to an interface, in C. - Sal_int, & ! The salinity interpolated to an interface, in psu. - dbuoy_dT, & ! The partial derivatives of buoyancy with changes in - dbuoy_dS, & ! temperature and salinity, in m s-2 K-1 and m s-2 psu-1. - I_L2_bdry, & ! The inverse of the square of twice the harmonic mean - ! distance to the top and bottom boundaries, in m-2. - K_Q, & ! Diffusivity divided by TKE, in s. - K_Q_tmp, & ! Diffusivity divided by TKE, in s. - local_src_avg, & ! The time-integral of the local source, nondim. - tol_min, & ! Minimum tolerated ksrc for the corrector step, in s-1. - tol_max, & ! Maximum tolerated ksrc for the corrector step, in s-1. - tol_chg, & ! The tolerated change integrated in time, nondim. - dist_from_top, & ! The distance from the top surface, in m. - local_src ! The sum of all sources of kappa, including kappa_src and - ! sources from the elliptic term, in s-1. + tke_avg ! The time-weighted average of TKE, in m2 s-2. real :: f2 ! The squared Coriolis parameter of each column, in s-2. - real :: dist_from_bot ! The distance from the bottom surface, in m. - - real :: b1 ! The inverse of the pivot in the tridiagonal equations. - real :: bd1 ! A term in the denominator of b1. - real :: d1 ! 1 - c1 in the tridiagonal equations. - real :: gR0 ! Rho_0 times g in kg m-2 s-2. - real :: g_R0 ! g_R0 is g/Rho in m4 kg-1 s-2. - real :: Norm ! A factor that normalizes two weights to 1, in m-2. - real :: tol_dksrc, tol2 ! ### Tolerances that need to be set better later. - real :: tol_dksrc_low ! The tolerance for the fractional decrease in ksrc - ! within an iteration. 0 < tol_dksrc_low < 1. - real :: Ri_crit ! The critical shear Richardson number for shear- - ! driven mixing. The theoretical value is 0.25. - real :: dt_rem ! The remaining time to advance the solution, in s. - real :: dt_now ! The time step used in the current iteration, in s. - real :: dt_wt ! The fractional weight of the current iteration, ND. - real :: dt_test ! A time-step that is being tested for whether it - ! gives acceptably small changes in k_src, in s. - real :: Idtt ! Idtt = 1 / dt_test, in s-1. - real :: dt_inc ! An increment to dt_test that is being tested, in s. + real :: surface_pres ! The top surface pressure, in Pa. real :: dz_in_lay ! The running sum of the thickness in a layer, in m. real :: k0dt ! The background diffusivity times the timestep, in m2. real :: dz_massless ! A layer thickness that is considered massless, in m. - logical :: valid_dt ! If true, all levels so far exhibit acceptably small - ! changes in k_src. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. logical :: new_kappa = .true. ! If true, ignore the value of kappa from the ! last call to this subroutine. - integer, dimension(SZK_(G)+1) :: kc ! The index map between the original + integer, dimension(SZK_(GV)+1) :: kc ! The index map between the original ! interfaces and the interfaces with massless layers ! merged into nearby massive layers. - real, dimension(SZK_(G)+1) :: kf ! The fractional weight of interface kc+1 for + real, dimension(SZK_(GV)+1) :: kf ! The fractional weight of interface kc+1 for ! interpolating back to the original index space, ND. - integer :: ks_kappa, ke_kappa ! The k-range with nonzero kappas. - integer :: dt_halvings ! The number of times that the time-step is halved - ! in seeking an acceptable timestep. If none is - ! found, dt_rem*0.5^dt_halvings is used. - integer :: dt_refinements ! The number of 2-fold refinements that will be used - ! to estimate the maximum permitted time step. I.e., - ! the resolution is 1/2^dt_refinements. - integer :: is, ie, js, je, i, j, k, nz, nzc, itt, itt_dt - - ! Arrays that are used in find_kappa_tke if it is included in this subroutine. - real, dimension(SZK_(G)) :: & - aQ, & ! aQ is the coupling between adjacent interfaces in the TKE - ! equations, in m s-1. - dQdz ! Half the partial derivative of TKE with depth, m s-2. - real, dimension(SZK_(G)+1) :: & - dK, & ! The change in kappa, in m2 s-1. - dQ, & ! The change in TKE, in m2 s-1. - cQ, cK, & ! cQ and cK are the upward influences in the tridiagonal and - ! hexadiagonal solvers for the TKE and kappa equations, ND. - I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale - ! for kappa, in units of m-2. - TKE_decay, & ! The local TKE decay rate in s-1. - dQmdK, & ! With Newton's method the change in dQ(K-1) due to dK(K), s. - dKdQ, & ! With Newton's method the change in dK(K) due to dQ(K), s-1. - e1 ! The fractional change in a layer TKE due to a change in the - ! TKE of the layer above when all the kappas below are 0. - ! e1 is nondimensional, and 0 < e1 < 1. - + integer :: is, ie, js, je, i, j, k, nz, nzc ! Diagnostics that should be deleted? #ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(G)+1) :: & ! Additional diagnostics. + real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. I_Ld2_1d - real, dimension(SZI_(G),SZK_(G)+1) :: & ! 2-D versions of diagnostics. + real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. I_Ld2_2d, dz_Int_2d - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & ! 3-D versions of diagnostics. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. I_Ld2_3d, dz_Int_3d #endif #ifdef DEBUG integer :: max_debug_itt ; parameter(max_debug_itt=20) - real :: wt(SZK_(G)+1), wt_tot, I_wt_tot, wt_itt - real, dimension(SZK_(G)+1) :: & + real :: wt(SZK_(GV)+1), wt_tot, I_wt_tot, wt_itt + real, dimension(SZK_(GV)+1) :: & Ri_k, tke_prev, dtke, dkappa, dtke_norm, & ksrc_av ! The average through the iterations of k_src, in s-1. - real, dimension(SZK_(G)+1,0:max_debug_itt) :: & + real, dimension(SZK_(GV)+1,0:max_debug_itt) :: & tke_it1, N2_it1, Sh2_it1, ksrc_it1, kappa_it1, kprev_it1 - real, dimension(SZK_(G)+1,1:max_debug_itt) :: & + real, dimension(SZK_(GV)+1,1:max_debug_itt) :: & dkappa_it1, wt_it1, K_Q_it1, d_dkappa_it1, dkappa_norm - real, dimension(SZK_(G),0:max_debug_itt) :: & + real, dimension(SZK_(GV),0:max_debug_itt) :: & u_it1, v_it1, rho_it1, T_it1, S_it1 real, dimension(0:max_debug_itt) :: & dk_wt_it1, dkpos_wt_it1, dkneg_wt_it1, k_mag real, dimension(max_debug_itt) :: dt_it1 #endif - 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 ; nz = GV%ke ! These are hard-coded for now. Perhaps these could be made dynamic later? ! tol_dksrc = 0.5*tol_ksrc_chg ; tol_dksrc_low = 1.0 - 1.0/tol_ksrc_chg ? - tol_dksrc = 10.0 ; tol_dksrc_low = 0.95 ; tol2 = 2.0*CS%kappa_tol_err - dt_refinements = 5 ! Selected so that 1/2^dt_refinements < 1-tol_dksrc_low +! tol_dksrc = 10.0 ; tol_dksrc_low = 0.95 ; tol2 = 2.0*CS%kappa_tol_err +! dt_refinements = 5 ! Selected so that 1/2^dt_refinements < 1-tol_dksrc_low use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. new_kappa = .true. ; if (present(initialize_all)) new_kappa = initialize_all - Ri_crit = CS%Rino_crit - gR0 = GV%Rho0*GV%g_Earth ; g_R0 = GV%g_Earth/GV%Rho0 +! Ri_crit = CS%Rino_crit +! gR0 = GV%Rho0*GV%g_Earth ; g_R0 = GV%g_Earth/GV%Rho0 k0dt = dt*CS%kappa_0 dz_massless = 0.1*sqrt(k0dt) !$OMP parallel do default(none) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,new_kappa, & -!$OMP tv,G,GV,CS,kappa_io,dz_massless,k0dt,p_surf,gR0,g_R0, & -!$OMP dt,tol_dksrc,tol_dksrc_low,tol2,dt_refinements, & +!$OMP tv,G,GV,CS,kappa_io,dz_massless,k0dt,p_surf,dt, & #ifdef ADD_DIAGNOSTICS !$OMP I_Ld2_3d,dz_Int_3d, & #endif -!$OMP Ri_crit,tke_io,kv_io) & +!$OMP tke_io,kv_io) & !$OMP private(h_2d,u_2d,v_2d,T_2d,S_2d,rho_2d,kappa_2d,nzc,dz, & -!$OMP u0xdz,v0xdz,T0xdz,S0xdz,kc,Idz,kf,I_dz_int,dz_in_lay, & -!$OMP dist_from_top,a1,b1,u,v,T,Sal,c1,d1,bd1,dz_Int,Norm, & -!$OMP dist_from_bot,I_L2_bdry,f2,pressure,T_int,Sal_int, & -!$OMP dbuoy_dT,dbuoy_dS,kappa,K_Q,N2,S2,dt_rem,kappa_avg, & -!$OMP tke_avg,local_src_avg,tke,kappa_out,kappa_src, & -!$OMP local_src,ks_kappa,ke_kappa,dt_now,dt_test,tol_max, & -!$OMP tol_min,tol_chg,u_test, v_test, T_test, S_test, & -!$OMP valid_dt,Idtt,k_src,dt_inc,dt_wt,kappa_mid,K_Q_tmp, & +!$OMP u0xdz,v0xdz,T0xdz,S0xdz,kc,Idz,kf,dz_in_lay, & +!$OMP u,v,T,Sal,f2,kappa,kappa_avg,tke_avg,tke,surface_pres,& #ifdef ADD_DIAGNOSTICS !$OMP I_Ld2_1d,I_Ld2_2d, dz_Int_2d, & #endif -!$OMP tke_pred,kappa_pred,tke_2d) +!$OMP tke_2d) do j=js,je do k=1,nz ; do i=is,ie @@ -400,6 +310,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif enddo kc(nz+1) = nzc+1 + ! Set up Idz as the inverse of layer thicknesses. do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo @@ -430,418 +341,30 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo - ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo - endif - - ! Set up I_dz_int as the inverse of the distance between - ! adjacent layer centers. - I_dz_int(1) = 2.0 / dz(1) - dist_from_top(1) = 0.0 - do K=2,nzc - I_dz_int(K) = 2.0 / (dz(k-1) + dz(k)) - dist_from_top(K) = dist_from_top(K-1) + dz(k-1) - enddo - I_dz_int(nzc+1) = 2.0 / dz(nzc) - - ! Determine the velocities and thicknesses after eliminating massless - ! layers and applying a time-step of background diffusion. - if (nzc > 1) then - a1(2) = k0dt*I_dz_int(2) - b1 = 1.0 / (dz(1)+a1(2)) - u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) - T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) - c1(2) = a1(2) * b1 ; d1 = dz(1) * b1 ! = 1 - c1 - do k=2,nzc-1 - bd1 = dz(k) + d1*a1(k) - a1(k+1) = k0dt*I_dz_int(k+1) - b1 = 1.0 / (bd1 + a1(k+1)) - u(k) = b1 * (u0xdz(k) + a1(k)*u(k-1)) - v(k) = b1 * (v0xdz(k) + a1(k)*v(k-1)) - T(k) = b1 * (T0xdz(k) + a1(k)*T(k-1)) - Sal(k) = b1 * (S0xdz(k) + a1(k)*Sal(k-1)) - c1(k+1) = a1(k+1) * b1 ; d1 = bd1 * b1 ! d1 = 1 - c1 - enddo - ! rho or T and S have insulating boundary conditions, u & v use no-slip - ! bottom boundary conditions (if kappa0 > 0). - ! For no-slip bottom boundary conditions - b1 = 1.0 / ((dz(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) - u(nzc) = b1 * (u0xdz(nzc) + a1(nzc)*u(nzc-1)) - v(nzc) = b1 * (v0xdz(nzc) + a1(nzc)*v(nzc-1)) - ! For insulating boundary conditions - b1 = 1.0 / (dz(nzc) + d1*a1(nzc)) - T(nzc) = b1 * (T0xdz(nzc) + a1(nzc)*T(nzc-1)) - Sal(nzc) = b1 * (S0xdz(nzc) + a1(nzc)*Sal(nzc-1)) - do k=nzc-1,1,-1 - u(k) = u(k) + c1(k+1)*u(k+1) ; v(k) = v(k) + c1(k+1)*v(k+1) - T(k) = T(k) + c1(k+1)*T(k+1) ; Sal(k) = Sal(k) + c1(k+1)*Sal(k+1) - enddo - else - ! This is correct, but probably unnecessary. - b1 = 1.0 / (dz(1) + k0dt*I_dz_int(2)) - u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) - b1 = 1.0 / dz(1) - T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) endif - - ! This uses half the harmonic mean of thicknesses to provide two estimates - ! of the boundary between cells, and the inverse of the harmonic mean to - ! weight the two estimates. The net effect is that interfaces around thin - ! layers have thin cells, and the total thickness adds up properly. - ! The top- and bottom- interfaces have zero thickness, consistent with - ! adding additional zero thickness layers. - dz_Int(1) = 0.0 ; dz_Int(2) = dz(1) - do K=2,nzc-1 - Norm = 1.0 / (dz(k)*(dz(k-1)+dz(k+1)) + 2.0*dz(k-1)*dz(k+1)) - dz_Int(K) = dz_Int(K) + dz(k) * ( ((dz(k)+dz(k+1)) * dz(k-1)) * Norm) - dz_Int(K+1) = dz(k) * ( ((dz(k-1)+dz(k)) * dz(k+1)) * Norm) - enddo - dz_Int(nzc) = dz_Int(nzc) + dz(nzc) ; dz_Int(nzc+1) = 0.0 - -#ifdef ADD_DIAGNOSTICS - do K=1,nzc+1 ; I_Ld2_1d(K) = 0.0 ; enddo -#endif - - dist_from_bot = 0.0 - do K=nzc,2,-1 - dist_from_bot = dist_from_bot + dz(k) - I_L2_bdry(K) = (dist_from_top(K) + dist_from_bot)**2 / & - (dist_from_top(K) * dist_from_bot)**2 - enddo f2 = 0.25*((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) - - ! Calculate thermodynamic coefficients and an initial estimate of N2. - if (use_temperature) then - pressure(1) = 0.0 - if (associated(p_surf)) pressure(1) = p_surf(i,j) - do K=2,nzc - pressure(K) = pressure(K-1) + gR0*dz(k-1) - T_int(K) = 0.5*(T(k-1) + T(k)) - Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) - enddo - call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, & - dbuoy_dS, 2, nzc-1, tv%eqn_of_state) - do K=2,nzc - dbuoy_dT(K) = -G_R0*dbuoy_dT(K) - dbuoy_dS(K) = -G_R0*dbuoy_dS(K) - enddo - else - do K=1,nzc+1 ; dbuoy_dT(K) = -G_R0 ; dbuoy_dS(K) = 0.0 ; enddo - endif + surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) ! ---------------------------------------------------- - ! Calculate kappa, here defined at interfaces. + ! Set the initial guess for kappa, here defined at interfaces. ! ---------------------------------------------------- if (new_kappa) then - do K=1,nzc+1 ; kappa(K) = 1.0 ; K_Q(K) = 0.0 ; enddo + do K=1,nzc+1 ; kappa(K) = 1.0 ; enddo else - do K=1,nzc+1 ; kappa(K) = kappa_2d(i,K) ; K_Q(K) = 0.0 ; enddo + do K=1,nzc+1 ; kappa(K) = kappa_2d(i,K) ; enddo endif -#ifdef DEBUG - N2(1) = 0.0 ; N2(nzc+1) = 0.0 - do K=2,nzc - N2(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & - dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & - I_dz_int(K), 0.0) - enddo - do k=1,nzc - u_it1(k,0) = u0xdz(k)*Idz(k) ; v_it1(k,0) = v0xdz(k)*Idz(k) - T_it1(k,0) = T0xdz(k)*Idz(k) ; S_it1(k,0) = S0xdz(k)*Idz(k) - enddo - do K=1,nzc+1 - kprev_it1(K,0) = kappa(K) ; kappa_it1(K,0) = kappa(K) - tke_it1(K,0) = tke(K) - N2_it1(K,0) = N2(K) ; Sh2_it1(K,0) = S2(K) ; ksrc_it1(K,0) = k_src(K) - enddo - do k=nzc+1,nz - u_it1(k,0) = 0.0 ; v_it1(k,0) = 0.0 - T_it1(k,0) = 0.0 ; S_it1(k,0) = 0.0 - kprev_it1(K+1,0) = 0.0 ; kappa_it1(K+1,0) = 0.0 ; tke_it1(K+1,0) = 0.0 - N2_it1(K+1,0) = 0.0 ; Sh2_it1(K+1,0) = 0.0 ; ksrc_it1(K+1,0) = 0.0 - enddo - do itt=1,max_debug_itt - dt_it1(itt) = 0.0 - do k=1,nz - u_it1(k,itt) = 0.0 ; v_it1(k,itt) = 0.0 - T_it1(k,itt) = 0.0 ; S_it1(k,itt) = 0.0 - rho_it1(k,itt) = 0.0 - enddo - do K=1,nz+1 - kprev_it1(K,itt) = 0.0 ; kappa_it1(K,itt) = 0.0 ; tke_it1(K,itt) = 0.0 - N2_it1(K,itt) = 0.0 ; Sh2_it1(K,itt) = 0.0 - ksrc_it1(K,itt) = 0.0 - dkappa_it1(K,itt) = 0.0 ; wt_it1(K,itt) = 0.0 - K_Q_it1(K,itt) = 0.0 ; d_dkappa_it1(K,itt) = 0.0 - enddo - enddo - do K=1,nz+1 ; ksrc_av(K) = 0.0 ; enddo -#endif - - ! This call just calculates N2 and S2. - call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u, v, T, Sal, N2=N2, S2=S2) - ! ---------------------------------------------------- - ! Iterate - ! ---------------------------------------------------- - dt_rem = dt - do K=1,nzc+1 - kappa_avg(K) = 0.0 ; tke_avg(K) = 0.0 - local_src_avg(K) = 0.0 - ! Use the grid spacings to scale errors in the source. - if ( dz_Int(K) > 0.0 ) & - local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / dz_Int(K) - enddo - - ! call cpu_clock_end(id_clock_setup) - -! do itt=1,CS%max_RiNo_it - do itt=1,CS%max_KS_it - - ! ---------------------------------------------------- - ! Calculate new values of u, v, rho, N^2 and S. - ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (S2(K) > 1e-3*N2(K)) Ri_k(K) = N2(K) / S2(K) - tke_prev(K) = tke(K) - enddo -#endif - - ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & - nzc, CS, K_Q, tke, kappa_out, kappa_src, local_src) - ! call cpu_clock_end(id_clock_KQ) - - ! call cpu_clock_begin(id_clock_avg) - ! Determine the range of non-zero values of kappa_out. - ks_kappa = nz+1 ; ke_kappa = 0 - do K=2,nzc ; if (kappa_out(K) > 0.0) then - ks_kappa = K ; exit - endif ; enddo - do k=nzc,ks_kappa,-1 ; if (kappa_out(K) > 0.0) then - ke_kappa = K ; exit - endif ; enddo - if (ke_kappa == nzc) kappa_out(nzc+1) = 0.0 - ! call cpu_clock_end(id_clock_avg) - - ! Determine how long to use this value of kappa (dt_now). - - ! call cpu_clock_begin(id_clock_project) - if ((ke_kappa < ks_kappa) .or. (itt==CS%max_RiNo_it)) then - dt_now = dt_rem - else - ! Limit dt_now so that |k_src(k)-kappa_src(k)| < tol * local_src(k) - dt_test = dt_rem - do K=2,nzc - tol_max(K) = kappa_src(K) + tol_dksrc * local_src(K) - tol_min(K) = kappa_src(K) - tol_dksrc_low * local_src(K) - tol_chg(K) = tol2 * local_src_avg(K) - enddo - - do itt_dt=1,(CS%max_KS_it+1-itt)/2 - ! The maximum number of times that the time-step is halved in - ! seeking an acceptable timestep is reduced with each iteration, - ! so that as the maximum number of iterations is approached, the - ! whole remaining timestep is used. Typically, an acceptable - ! timestep is found long before the minimum is reached, so the - ! value of max_KS_it may be unimportant, especially if it is large - ! enough. - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u_test, v_test, T_test, S_test, N2, S2, & - ks_int = ks_kappa, ke_int = ke_kappa) - valid_dt = .true. - Idtt = 1.0 / dt_test - do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) - if (N2(K) < Ri_crit * S2(K)) then ! Equivalent to Ri < Ri_crit. - k_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & - ((Ri_crit*S2(K) - N2(K)) / (Ri_crit*S2(K) + CS%FRi_curvature*N2(K))) - if ((k_src(K) > max(tol_max(K), kappa_src(K) + Idtt*tol_chg(K))) .or. & - (k_src(K) < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K)))) then - valid_dt = .false. ; exit - endif - else - if (0.0 < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K))) then - valid_dt = .false. ; k_src(K) = 0.0 ; exit - endif - endif - enddo - - if (valid_dt) exit - dt_test = 0.5*dt_test - enddo - if ((dt_test < dt_rem) .and. valid_dt) then - dt_inc = 0.5*dt_test - do itt_dt=1,dt_refinements - call calculate_projected_state(kappa_out, u, v, T, Sal, & - 0.5*(dt_test+dt_inc), nzc, dz, I_dz_int, dbuoy_dT, & - dbuoy_dS, u_test, v_test, T_test, S_test, N2, S2, & - ks_int = ks_kappa, ke_int = ke_kappa) - valid_dt = .true. - Idtt = 1.0 / (dt_test+dt_inc) - do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) - if (N2(K) < Ri_crit * S2(K)) then ! Equivalent to Ri < Ri_crit. - k_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & - ((Ri_crit*S2(K) - N2(K)) / & - (Ri_crit*S2(K) + CS%FRi_curvature*N2(K))) - if ((k_src(K) > max(tol_max(K), kappa_src(K) + Idtt*tol_chg(K))) .or. & - (k_src(K) < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K)))) then - valid_dt = .false. ; exit - endif - else - if (0.0 < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K))) then - valid_dt = .false. ; k_src(K) = 0.0 ; exit - endif - endif - enddo - - if (valid_dt) dt_test = dt_test + dt_inc - dt_inc = 0.5*dt_inc - enddo - else - dt_inc = 0.0 - endif - - dt_now = min(dt_test*(1.0+CS%kappa_tol_err)+dt_inc,dt_rem) - do K=2,nzc - local_src_avg(K) = local_src_avg(K) + dt_now * local_src(K) - enddo - endif ! Are all the values of kappa_out 0? - ! call cpu_clock_end(id_clock_project) - - ! The state has already been projected forward. Now find new values of kappa. - - if (ke_kappa < ks_kappa) then - ! There is no mixing now, and will not be again. - ! call cpu_clock_begin(id_clock_avg) - dt_wt = dt_rem / dt ; dt_rem = 0.0 - do K=1,nzc+1 - kappa_mid(K) = 0.0 - ! This would be here but does nothing. - ! kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt - tke_avg(K) = tke_avg(K) + dt_wt*tke(K) -#ifdef DEBUG - tke_pred(K) = tke(K) ; kappa_pred(K) = 0.0 ; kappa(K) = 0.0 -#endif - enddo - ! call cpu_clock_end(id_clock_avg) - else - ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u_test, v_test, T_test, S_test, N2=N2, S2=S2, & - ks_int = ks_kappa, ke_int = ke_kappa) - ! call cpu_clock_end(id_clock_project) - - ! call cpu_clock_begin(id_clock_KQ) - do K=1,nzc+1 ; K_Q_tmp(K) = K_Q(K) ; enddo - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & - nzc, CS, K_Q_tmp, tke_pred, kappa_pred) - ! call cpu_clock_end(id_clock_KQ) - - ks_kappa = nz+1 ; ke_kappa = 0 - do K=1,nzc+1 - kappa_mid(K) = 0.5*(kappa_out(K) + kappa_pred(K)) - if ((kappa_mid(K) > 0.0) .and. (K 0.0) ke_kappa = K - enddo - - ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u_test, v_test, T_test, S_test, N2=N2, S2=S2, & - ks_int = ks_kappa, ke_int = ke_kappa) - ! call cpu_clock_end(id_clock_project) - - ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & - nzc, CS, K_Q, tke_pred, kappa_pred) - ! call cpu_clock_end(id_clock_KQ) - - ! call cpu_clock_begin(id_clock_avg) - dt_wt = dt_now / dt ; dt_rem = dt_rem - dt_now - do K=1,nzc+1 - kappa_mid(K) = 0.5*(kappa_out(K) + kappa_pred(K)) - kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt - tke_avg(K) = tke_avg(K) + dt_wt*0.5*(tke_pred(K) + tke(K)) - kappa(K) = kappa_pred(K) ! First guess for the next iteration. - enddo - ! call cpu_clock_end(id_clock_avg) - endif - - if (dt_rem > 0.0) then - ! Update the values of u, v, T, Sal, N2, and S2 for the next iteration. - ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u, v, T, Sal, N2, S2) - ! call cpu_clock_end(id_clock_project) - endif - -#ifdef DEBUG - if (itt <= max_debug_itt) then - dt_it1(itt) = dt_now - dk_wt_it1(itt) = 0.0 ; dkpos_wt_it1(itt) = 0.0 ; dkneg_wt_it1(itt) = 0.0 - k_mag(itt) = 0.0 - wt_itt = 1.0/real(itt) ; wt_tot = 0.0 - do K=1,nzc+1 - ksrc_av(K) = (1.0-wt_itt)*ksrc_av(K) + wt_itt*k_src(K) - wt_tot = wt_tot + dz_Int(K) * ksrc_av(K) - enddo - ! Use the 1/0=0 convention. - I_wt_tot = 0.0 ; if (wt_tot > 0.0) I_wt_tot = 1.0/wt_tot - - do K=1,nzc+1 - wt(K) = (dz_Int(K)*ksrc_av(K)) * I_wt_tot - k_mag(itt) = k_mag(itt) + wt(K)*kappa_mid(K) - dkappa_it1(K,itt) = kappa_pred(K) - kappa_out(K) - dk_wt_it1(itt) = dk_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - if (dk > 0.0) then - dkpos_wt_it1(itt) = dkpos_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - else - dkneg_wt_it1(itt) = dkneg_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - endif - wt_it1(K,itt) = wt(K) - enddo - endif - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (N2(K) < 1e3 * S2(K)) Ri_k(K) = N2(K) / S2(K) - dtke(K) = tke_pred(K) - tke(K) - dtke_norm(K) = dtke(K) / (0.5*(tke(K) + tke_pred(K))) - dkappa(K) = kappa_pred(K) - kappa_out(K) - enddo - if (itt <= max_debug_itt) then - do k=1,nzc - u_it1(k,itt) = u(k) ; v_it1(k,itt) = v(k) - T_it1(k,itt) = T(k) ; S_it1(k,itt) = Sal(k) - enddo - do K=1,nzc+1 - kprev_it1(K,itt)=kappa_out(K) - kappa_it1(K,itt)=kappa_mid(K) ; tke_it1(K,itt) = 0.5*(tke(K)+tke_pred(K)) - N2_it1(K,itt)=N2(K) ; Sh2_it1(K,itt)=S2(K) - ksrc_it1(K,itt) = kappa_src(K) - K_Q_it1(K,itt) = kappa_out(K) / (TKE(K)) - if (itt > 1) then - if (abs(dkappa_it1(K,itt-1)) > 1e-20) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - dkappa_norm(K,itt) = dkappa(K) / max(0.5*(Kappa_pred(K) + kappa_out(K)), 1e-100) - enddo - endif -#endif - - if (dt_rem <= 0.0) exit - - enddo ! end itt loop + call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & + dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + tke_avg, tv, CS, GV) ! call cpu_clock_begin(id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. if (nz == nzc) then do K=1,nz+1 kappa_2d(i,K) = kappa_avg(K) + !### Should this be tke_avg? tke_2d(i,K) = tke(K) enddo else @@ -908,6 +431,524 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & end subroutine Calculate_kappa_shear +subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & + dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + tke_avg, tv, CS, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), & + intent(inout) :: kappa !< The time-weighted average of kappa, in m2 s-1. + real, dimension(SZK_(GV)+1), & + intent(inout) :: tke !< The Turbulent Kinetic Energy per unit mass at + !! an interface, in units of m2 s-2. + integer, intent(in) :: nzc !< The number of active layers in the column. + real, intent(in) :: f2 !< The square of the Coriolis parameter, in s-2. + real, intent(in) :: surface_pres !< The surface pressure, in Pa. + real, dimension(SZK_(GV)), & + intent(in) :: dz !< The layer thickness, in m. + real, dimension(SZK_(GV)), & + intent(in) :: u0xdz !< The initial zonal velocity times dz, in m2 s-1. + real, dimension(SZK_(GV)), & + intent(in) :: v0xdz !< The initial meridional velocity times dz, in m2 s-1. + real, dimension(SZK_(GV)), & + intent(in) :: T0xdz !< The initial temperature times dz, in C m. + real, dimension(SZK_(GV)), & + intent(in) :: S0xdz !< The initial salinity times dz, in PSU m. + real, dimension(SZK_(GV)+1), & + intent(out) :: kappa_avg !< The time-weighted average of kappa, in m2 s-1. + real, dimension(SZK_(GV)+1), & + intent(out) :: tke_avg !< The time-weighted average of TKE, in m2 s-2. + real, intent(in) :: dt !< Time increment, in s. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL ptrs. + type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous + !! call to kappa_shear_init. + + real, dimension(nzc) :: & + u, & ! The zonal velocity after a timestep of mixing, in m s-1. + v, & ! The meridional velocity after a timestep of mixing, in m s-1. + Idz, & ! The inverse of the distance between TKE points, in m. + T, & ! The potential temperature after a timestep of mixing, in C. + Sal, & ! The salinity after a timestep of mixing, in psu. + u_test, v_test, T_test, S_test + + + real, dimension(nzc+1) :: & + N2, & ! The squared buoyancy frequency at an interface, in s-2. + dz_Int, & ! The extent of a finite-volume space surrounding an interface, + ! as used in calculating kappa and TKE, in m. + I_dz_int, & ! The inverse of the distance between velocity & density points + ! above and below an interface, in m-1. This is used to + ! calculate N2, shear, and fluxes, and it might differ from + ! 1/dz_Int, as they have different uses. + S2, & ! The squared shear at an interface, in s-2. + a1, & ! a1 is the coupling between adjacent interfaces in the TKE, + ! velocity, and density equations, in m s-1 or m. + c1, & ! c1 is used in the tridiagonal (and similar) solvers. + k_src, & ! The shear-dependent source term in the kappa equation, in s-1. + kappa_src, & ! The shear-dependent source term in the kappa equation in s-1. + kappa_out, & ! The kappa that results from the kappa equation, in m2 s-1. + kappa_mid, & ! The average of the initial and predictor estimates of kappa, + ! in units of m2 s-1. + tke_pred, & ! The value of TKE from a predictor step, in m2 s-2. + kappa_pred, & ! The value of kappa from a predictor step, in m2 s-1. + pressure, & ! The pressure at an interface, in Pa. + T_int, & ! The temperature interpolated to an interface, in C. + Sal_int, & ! The salinity interpolated to an interface, in psu. + dbuoy_dT, & ! The partial derivatives of buoyancy with changes in + dbuoy_dS, & ! temperature and salinity, in m s-2 K-1 and m s-2 psu-1. + I_L2_bdry, & ! The inverse of the square of twice the harmonic mean + ! distance to the top and bottom boundaries, in m-2. + K_Q, & ! Diffusivity divided by TKE, in s. + K_Q_tmp, & ! Diffusivity divided by TKE, in s. + local_src_avg, & ! The time-integral of the local source, nondim. + tol_min, & ! Minimum tolerated ksrc for the corrector step, in s-1. + tol_max, & ! Maximum tolerated ksrc for the corrector step, in s-1. + tol_chg, & ! The tolerated change integrated in time, nondim. + dist_from_top, & ! The distance from the top surface, in m. + local_src ! The sum of all sources of kappa, including kappa_src and + ! sources from the elliptic term, in s-1. + + real :: dist_from_bot ! The distance from the bottom surface, in m. + real :: b1 ! The inverse of the pivot in the tridiagonal equations. + real :: bd1 ! A term in the denominator of b1. + real :: d1 ! 1 - c1 in the tridiagonal equations. + real :: gR0 ! Rho_0 times g in kg m-2 s-2. + real :: g_R0 ! g_R0 is g/Rho in m4 kg-1 s-2. + real :: Norm ! A factor that normalizes two weights to 1, in m-2. + real :: tol_dksrc, tol2 ! ### Tolerances that need to be set better later. + real :: tol_dksrc_low ! The tolerance for the fractional decrease in ksrc + ! within an iteration. 0 < tol_dksrc_low < 1. + real :: Ri_crit ! The critical shear Richardson number for shear- + ! driven mixing. The theoretical value is 0.25. + real :: dt_rem ! The remaining time to advance the solution, in s. + real :: dt_now ! The time step used in the current iteration, in s. + real :: dt_wt ! The fractional weight of the current iteration, ND. + real :: dt_test ! A time-step that is being tested for whether it + ! gives acceptably small changes in k_src, in s. + real :: Idtt ! Idtt = 1 / dt_test, in s-1. + real :: dt_inc ! An increment to dt_test that is being tested, in s. + + real :: k0dt ! The background diffusivity times the timestep, in m2. + logical :: valid_dt ! If true, all levels so far exhibit acceptably small + ! changes in k_src. + logical :: use_temperature ! If true, temperature and salinity have been + ! allocated and are being used as state variables. + integer :: ks_kappa, ke_kappa ! The k-range with nonzero kappas. + integer :: dt_halvings ! The number of times that the time-step is halved + ! in seeking an acceptable timestep. If none is + ! found, dt_rem*0.5^dt_halvings is used. + integer :: dt_refinements ! The number of 2-fold refinements that will be used + ! to estimate the maximum permitted time step. I.e., + ! the resolution is 1/2^dt_refinements. + integer :: k, itt, itt_dt + + Ri_crit = CS%Rino_crit + gR0 = GV%Rho0*GV%g_Earth ; g_R0 = GV%g_Earth/GV%Rho0 + k0dt = dt*CS%kappa_0 + ! These are hard-coded for now. Perhaps these could be made dynamic later? + ! tol_dksrc = 0.5*tol_ksrc_chg ; tol_dksrc_low = 1.0 - 1.0/tol_ksrc_chg ? + tol_dksrc = 10.0 ; tol_dksrc_low = 0.95 ; tol2 = 2.0*CS%kappa_tol_err + dt_refinements = 5 ! Selected so that 1/2^dt_refinements < 1-tol_dksrc_low + use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. + + + ! Set up Idz as the inverse of layer thicknesses. + do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + ! Set up I_dz_int as the inverse of the distance between + ! adjacent layer centers. + I_dz_int(1) = 2.0 / dz(1) + dist_from_top(1) = 0.0 + do K=2,nzc + I_dz_int(K) = 2.0 / (dz(k-1) + dz(k)) + dist_from_top(K) = dist_from_top(K-1) + dz(k-1) + enddo + I_dz_int(nzc+1) = 2.0 / dz(nzc) + + ! Determine the velocities and thicknesses after eliminating massless + ! layers and applying a time-step of background diffusion. + if (nzc > 1) then + a1(2) = k0dt*I_dz_int(2) + b1 = 1.0 / (dz(1)+a1(2)) + u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) + T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) + c1(2) = a1(2) * b1 ; d1 = dz(1) * b1 ! = 1 - c1 + do k=2,nzc-1 + bd1 = dz(k) + d1*a1(k) + a1(k+1) = k0dt*I_dz_int(k+1) + b1 = 1.0 / (bd1 + a1(k+1)) + u(k) = b1 * (u0xdz(k) + a1(k)*u(k-1)) + v(k) = b1 * (v0xdz(k) + a1(k)*v(k-1)) + T(k) = b1 * (T0xdz(k) + a1(k)*T(k-1)) + Sal(k) = b1 * (S0xdz(k) + a1(k)*Sal(k-1)) + c1(k+1) = a1(k+1) * b1 ; d1 = bd1 * b1 ! d1 = 1 - c1 + enddo + ! rho or T and S have insulating boundary conditions, u & v use no-slip + ! bottom boundary conditions (if kappa0 > 0). + ! For no-slip bottom boundary conditions + b1 = 1.0 / ((dz(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) + u(nzc) = b1 * (u0xdz(nzc) + a1(nzc)*u(nzc-1)) + v(nzc) = b1 * (v0xdz(nzc) + a1(nzc)*v(nzc-1)) + ! For insulating boundary conditions + b1 = 1.0 / (dz(nzc) + d1*a1(nzc)) + T(nzc) = b1 * (T0xdz(nzc) + a1(nzc)*T(nzc-1)) + Sal(nzc) = b1 * (S0xdz(nzc) + a1(nzc)*Sal(nzc-1)) + do k=nzc-1,1,-1 + u(k) = u(k) + c1(k+1)*u(k+1) ; v(k) = v(k) + c1(k+1)*v(k+1) + T(k) = T(k) + c1(k+1)*T(k+1) ; Sal(k) = Sal(k) + c1(k+1)*Sal(k+1) + enddo + else + ! This is correct, but probably unnecessary. + b1 = 1.0 / (dz(1) + k0dt*I_dz_int(2)) + u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) + b1 = 1.0 / dz(1) + T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) + endif + + ! This uses half the harmonic mean of thicknesses to provide two estimates + ! of the boundary between cells, and the inverse of the harmonic mean to + ! weight the two estimates. The net effect is that interfaces around thin + ! layers have thin cells, and the total thickness adds up properly. + ! The top- and bottom- interfaces have zero thickness, consistent with + ! adding additional zero thickness layers. + dz_Int(1) = 0.0 ; dz_Int(2) = dz(1) + do K=2,nzc-1 + Norm = 1.0 / (dz(k)*(dz(k-1)+dz(k+1)) + 2.0*dz(k-1)*dz(k+1)) + dz_Int(K) = dz_Int(K) + dz(k) * ( ((dz(k)+dz(k+1)) * dz(k-1)) * Norm) + dz_Int(K+1) = dz(k) * ( ((dz(k-1)+dz(k)) * dz(k+1)) * Norm) + enddo + dz_Int(nzc) = dz_Int(nzc) + dz(nzc) ; dz_Int(nzc+1) = 0.0 + +#ifdef ADD_DIAGNOSTICS + do K=1,nzc+1 ; I_Ld2_1d(K) = 0.0 ; enddo +#endif + + dist_from_bot = 0.0 + do K=nzc,2,-1 + dist_from_bot = dist_from_bot + dz(k) + I_L2_bdry(K) = (dist_from_top(K) + dist_from_bot)**2 / & + (dist_from_top(K) * dist_from_bot)**2 + enddo + + ! Calculate thermodynamic coefficients and an initial estimate of N2. + if (use_temperature) then + pressure(1) = surface_pres + do K=2,nzc + pressure(K) = pressure(K-1) + gR0*dz(k-1) + T_int(K) = 0.5*(T(k-1) + T(k)) + Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) + enddo + call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, & + dbuoy_dS, 2, nzc-1, tv%eqn_of_state) + do K=2,nzc + dbuoy_dT(K) = -G_R0*dbuoy_dT(K) + dbuoy_dS(K) = -G_R0*dbuoy_dS(K) + enddo + else + do K=1,nzc+1 ; dbuoy_dT(K) = -G_R0 ; dbuoy_dS(K) = 0.0 ; enddo + endif + +#ifdef DEBUG + N2(1) = 0.0 ; N2(nzc+1) = 0.0 + do K=2,nzc + N2(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & + dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & + I_dz_int(K), 0.0) + enddo + do k=1,nzc + u_it1(k,0) = u0xdz(k)*Idz(k) ; v_it1(k,0) = v0xdz(k)*Idz(k) + T_it1(k,0) = T0xdz(k)*Idz(k) ; S_it1(k,0) = S0xdz(k)*Idz(k) + enddo + do K=1,nzc+1 + kprev_it1(K,0) = kappa(K) ; kappa_it1(K,0) = kappa(K) + tke_it1(K,0) = tke(K) + N2_it1(K,0) = N2(K) ; Sh2_it1(K,0) = S2(K) ; ksrc_it1(K,0) = k_src(K) + enddo + do k=nzc+1,nz + u_it1(k,0) = 0.0 ; v_it1(k,0) = 0.0 + T_it1(k,0) = 0.0 ; S_it1(k,0) = 0.0 + kprev_it1(K+1,0) = 0.0 ; kappa_it1(K+1,0) = 0.0 ; tke_it1(K+1,0) = 0.0 + N2_it1(K+1,0) = 0.0 ; Sh2_it1(K+1,0) = 0.0 ; ksrc_it1(K+1,0) = 0.0 + enddo + do itt=1,max_debug_itt + dt_it1(itt) = 0.0 + do k=1,nz + u_it1(k,itt) = 0.0 ; v_it1(k,itt) = 0.0 + T_it1(k,itt) = 0.0 ; S_it1(k,itt) = 0.0 + rho_it1(k,itt) = 0.0 + enddo + do K=1,nz+1 + kprev_it1(K,itt) = 0.0 ; kappa_it1(K,itt) = 0.0 ; tke_it1(K,itt) = 0.0 + N2_it1(K,itt) = 0.0 ; Sh2_it1(K,itt) = 0.0 + ksrc_it1(K,itt) = 0.0 + dkappa_it1(K,itt) = 0.0 ; wt_it1(K,itt) = 0.0 + K_Q_it1(K,itt) = 0.0 ; d_dkappa_it1(K,itt) = 0.0 + enddo + enddo + do K=1,nz+1 ; ksrc_av(K) = 0.0 ; enddo +#endif + + ! This call just calculates N2 and S2. + call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, & + dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + u, v, T, Sal, N2=N2, S2=S2) +! ---------------------------------------------------- +! Iterate +! ---------------------------------------------------- + dt_rem = dt + do K=1,nzc+1 + K_Q(K) = 0.0 + kappa_avg(K) = 0.0 ; tke_avg(K) = 0.0 + local_src_avg(K) = 0.0 + ! Use the grid spacings to scale errors in the source. + if ( dz_Int(K) > 0.0 ) & + local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / dz_Int(K) + enddo + +! call cpu_clock_end(id_clock_setup) + +! do itt=1,CS%max_RiNo_it + do itt=1,CS%max_KS_it + +! ---------------------------------------------------- +! Calculate new values of u, v, rho, N^2 and S. +! ---------------------------------------------------- +#ifdef DEBUG + do K=1,nzc+1 + Ri_k(K) = 1e3 ; if (S2(K) > 1e-3*N2(K)) Ri_k(K) = N2(K) / S2(K) + tke_prev(K) = tke(K) + enddo +#endif + + ! call cpu_clock_begin(id_clock_KQ) + call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & + nzc, CS, K_Q, tke, kappa_out, kappa_src, local_src) + ! call cpu_clock_end(id_clock_KQ) + + ! call cpu_clock_begin(id_clock_avg) + ! Determine the range of non-zero values of kappa_out. + ks_kappa = GV%ke+1 ; ke_kappa = 0 + do K=2,nzc ; if (kappa_out(K) > 0.0) then + ks_kappa = K ; exit + endif ; enddo + do k=nzc,ks_kappa,-1 ; if (kappa_out(K) > 0.0) then + ke_kappa = K ; exit + endif ; enddo + if (ke_kappa == nzc) kappa_out(nzc+1) = 0.0 + ! call cpu_clock_end(id_clock_avg) + + ! Determine how long to use this value of kappa (dt_now). + + ! call cpu_clock_begin(id_clock_project) + if ((ke_kappa < ks_kappa) .or. (itt==CS%max_RiNo_it)) then + dt_now = dt_rem + else + ! Limit dt_now so that |k_src(k)-kappa_src(k)| < tol * local_src(k) + dt_test = dt_rem + do K=2,nzc + tol_max(K) = kappa_src(K) + tol_dksrc * local_src(K) + tol_min(K) = kappa_src(K) - tol_dksrc_low * local_src(K) + tol_chg(K) = tol2 * local_src_avg(K) + enddo + + do itt_dt=1,(CS%max_KS_it+1-itt)/2 + ! The maximum number of times that the time-step is halved in + ! seeking an acceptable timestep is reduced with each iteration, + ! so that as the maximum number of iterations is approached, the + ! whole remaining timestep is used. Typically, an acceptable + ! timestep is found long before the minimum is reached, so the + ! value of max_KS_it may be unimportant, especially if it is large + ! enough. + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, & + dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + u_test, v_test, T_test, S_test, N2, S2, & + ks_int = ks_kappa, ke_int = ke_kappa) + valid_dt = .true. + Idtt = 1.0 / dt_test + do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) + if (N2(K) < Ri_crit * S2(K)) then ! Equivalent to Ri < Ri_crit. + k_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & + ((Ri_crit*S2(K) - N2(K)) / (Ri_crit*S2(K) + CS%FRi_curvature*N2(K))) + if ((k_src(K) > max(tol_max(K), kappa_src(K) + Idtt*tol_chg(K))) .or. & + (k_src(K) < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K)))) then + valid_dt = .false. ; exit + endif + else + if (0.0 < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K))) then + valid_dt = .false. ; k_src(K) = 0.0 ; exit + endif + endif + enddo + + if (valid_dt) exit + dt_test = 0.5*dt_test + enddo + if ((dt_test < dt_rem) .and. valid_dt) then + dt_inc = 0.5*dt_test + do itt_dt=1,dt_refinements + call calculate_projected_state(kappa_out, u, v, T, Sal, & + 0.5*(dt_test+dt_inc), nzc, dz, I_dz_int, dbuoy_dT, & + dbuoy_dS, u_test, v_test, T_test, S_test, N2, S2, & + ks_int = ks_kappa, ke_int = ke_kappa) + valid_dt = .true. + Idtt = 1.0 / (dt_test+dt_inc) + do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) + if (N2(K) < Ri_crit * S2(K)) then ! Equivalent to Ri < Ri_crit. + k_src(K) = (2.0 * CS%Shearmix_rate * sqrt(S2(K))) * & + ((Ri_crit*S2(K) - N2(K)) / & + (Ri_crit*S2(K) + CS%FRi_curvature*N2(K))) + if ((k_src(K) > max(tol_max(K), kappa_src(K) + Idtt*tol_chg(K))) .or. & + (k_src(K) < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K)))) then + valid_dt = .false. ; exit + endif + else + if (0.0 < min(tol_min(K), kappa_src(K) - Idtt*tol_chg(K))) then + valid_dt = .false. ; k_src(K) = 0.0 ; exit + endif + endif + enddo + + if (valid_dt) dt_test = dt_test + dt_inc + dt_inc = 0.5*dt_inc + enddo + else + dt_inc = 0.0 + endif + + dt_now = min(dt_test*(1.0+CS%kappa_tol_err)+dt_inc,dt_rem) + do K=2,nzc + local_src_avg(K) = local_src_avg(K) + dt_now * local_src(K) + enddo + endif ! Are all the values of kappa_out 0? + ! call cpu_clock_end(id_clock_project) + + ! The state has already been projected forward. Now find new values of kappa. + + if (ke_kappa < ks_kappa) then + ! There is no mixing now, and will not be again. + ! call cpu_clock_begin(id_clock_avg) + dt_wt = dt_rem / dt ; dt_rem = 0.0 + do K=1,nzc+1 + kappa_mid(K) = 0.0 + ! This would be here but does nothing. + ! kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt + tke_avg(K) = tke_avg(K) + dt_wt*tke(K) +#ifdef DEBUG + tke_pred(K) = tke(K) ; kappa_pred(K) = 0.0 ; kappa(K) = 0.0 +#endif + enddo + ! call cpu_clock_end(id_clock_avg) + else + ! call cpu_clock_begin(id_clock_project) + call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, & + dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + u_test, v_test, T_test, S_test, N2=N2, S2=S2, & + ks_int = ks_kappa, ke_int = ke_kappa) + ! call cpu_clock_end(id_clock_project) + + ! call cpu_clock_begin(id_clock_KQ) + do K=1,nzc+1 ; K_Q_tmp(K) = K_Q(K) ; enddo + call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + nzc, CS, K_Q_tmp, tke_pred, kappa_pred) + ! call cpu_clock_end(id_clock_KQ) + + ks_kappa = GV%ke+1 ; ke_kappa = 0 + do K=1,nzc+1 + kappa_mid(K) = 0.5*(kappa_out(K) + kappa_pred(K)) + if ((kappa_mid(K) > 0.0) .and. (K 0.0) ke_kappa = K + enddo + + ! call cpu_clock_begin(id_clock_project) + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, & + dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + u_test, v_test, T_test, S_test, N2=N2, S2=S2, & + ks_int = ks_kappa, ke_int = ke_kappa) + ! call cpu_clock_end(id_clock_project) + + ! call cpu_clock_begin(id_clock_KQ) + call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + nzc, CS, K_Q, tke_pred, kappa_pred) + ! call cpu_clock_end(id_clock_KQ) + + ! call cpu_clock_begin(id_clock_avg) + dt_wt = dt_now / dt ; dt_rem = dt_rem - dt_now + do K=1,nzc+1 + kappa_mid(K) = 0.5*(kappa_out(K) + kappa_pred(K)) + kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt + tke_avg(K) = tke_avg(K) + dt_wt*0.5*(tke_pred(K) + tke(K)) + kappa(K) = kappa_pred(K) ! First guess for the next iteration. + enddo + ! call cpu_clock_end(id_clock_avg) + endif + + if (dt_rem > 0.0) then + ! Update the values of u, v, T, Sal, N2, and S2 for the next iteration. + ! call cpu_clock_begin(id_clock_project) + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, & + dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + u, v, T, Sal, N2, S2) + ! call cpu_clock_end(id_clock_project) + endif + +#ifdef DEBUG + if (itt <= max_debug_itt) then + dt_it1(itt) = dt_now + dk_wt_it1(itt) = 0.0 ; dkpos_wt_it1(itt) = 0.0 ; dkneg_wt_it1(itt) = 0.0 + k_mag(itt) = 0.0 + wt_itt = 1.0/real(itt) ; wt_tot = 0.0 + do K=1,nzc+1 + ksrc_av(K) = (1.0-wt_itt)*ksrc_av(K) + wt_itt*k_src(K) + wt_tot = wt_tot + dz_Int(K) * ksrc_av(K) + enddo + ! Use the 1/0=0 convention. + I_wt_tot = 0.0 ; if (wt_tot > 0.0) I_wt_tot = 1.0/wt_tot + + do K=1,nzc+1 + wt(K) = (dz_Int(K)*ksrc_av(K)) * I_wt_tot + k_mag(itt) = k_mag(itt) + wt(K)*kappa_mid(K) + dkappa_it1(K,itt) = kappa_pred(K) - kappa_out(K) + dk_wt_it1(itt) = dk_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) + if (dk > 0.0) then + dkpos_wt_it1(itt) = dkpos_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) + else + dkneg_wt_it1(itt) = dkneg_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) + endif + wt_it1(K,itt) = wt(K) + enddo + endif + do K=1,nzc+1 + Ri_k(K) = 1e3 ; if (N2(K) < 1e3 * S2(K)) Ri_k(K) = N2(K) / S2(K) + dtke(K) = tke_pred(K) - tke(K) + dtke_norm(K) = dtke(K) / (0.5*(tke(K) + tke_pred(K))) + dkappa(K) = kappa_pred(K) - kappa_out(K) + enddo + if (itt <= max_debug_itt) then + do k=1,nzc + u_it1(k,itt) = u(k) ; v_it1(k,itt) = v(k) + T_it1(k,itt) = T(k) ; S_it1(k,itt) = Sal(k) + enddo + do K=1,nzc+1 + kprev_it1(K,itt)=kappa_out(K) + kappa_it1(K,itt)=kappa_mid(K) ; tke_it1(K,itt) = 0.5*(tke(K)+tke_pred(K)) + N2_it1(K,itt)=N2(K) ; Sh2_it1(K,itt)=S2(K) + ksrc_it1(K,itt) = kappa_src(K) + K_Q_it1(K,itt) = kappa_out(K) / (TKE(K)) + if (itt > 1) then + if (abs(dkappa_it1(K,itt-1)) > 1e-20) & + d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) + endif + dkappa_norm(K,itt) = dkappa(K) / max(0.5*(Kappa_pred(K) + kappa_out(K)), 1e-100) + enddo + endif +#endif + + if (dt_rem <= 0.0) exit + + enddo ! end itt loop + +end subroutine kappa_shear_column + subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, & dz, I_dz_int, dbuoy_dT, dbuoy_dS, & u, v, T, Sal, N2, S2, ks_int, ke_int) From 61f486b7b0020909d2418ec9eb0a61b44464b6c8 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Wed, 17 Jan 2018 19:43:14 -0500 Subject: [PATCH 113/170] An attempt to add checksum for restart fields to restart files - First test worked. - Need cleanup --- src/framework/MOM_io.F90 | 30 +++++++- src/framework/MOM_restart.F90 | 141 ++++++++++++++++++++++++++++++++-- 2 files changed, 162 insertions(+), 9 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index f1ff2ca853..ec0952c714 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -84,7 +84,7 @@ module MOM_io !> Routine creates a new NetCDF file. It also sets up !! structures that describe this file and variables that will !! later be written to this file. Type for describing a variable, typically a tracer -subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit, G, dG, GV) +subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit, G, dG, GV, checksums) integer, intent(out) :: unit !< unit id of an open file or -1 on a !! nonwriting PE with single file output character(len=*), intent(in) :: filename !< full path to the file to create @@ -103,6 +103,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit type(verticalGrid_type), optional, intent(in) :: GV !< ocean vertical grid structure, which is !! required if the new file uses any !! vertical grid axes. + integer(kind=8), optional, intent(in) :: checksums(:,:) !< checksums of vars logical :: use_lath, use_lonh, use_latq, use_lonq, use_time logical :: use_layer, use_int, use_periodic @@ -320,8 +321,13 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit end select pack = 1 - call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + if(present(checksums)) then + call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + vars(k)%longname, pack = pack, checksum=checksums(k,:)) + else + call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack) + endif enddo if (use_lath) call write_field(unit, axis_lath) @@ -947,6 +953,26 @@ subroutine MOM_io_init(param_file) end subroutine MOM_io_init +!The following won't compile, otherwise I could have used it to write the checksum attribute for each field +!MOM_io.F90(966): error #6292: The parent type of this field is use associated +!with the PRIVATE fields attribute. [ID] +! call mpp_write_meta( unit, field%id, trim(meta_name), cval=meta_char ) +!-----------------------------------^ +! +!subroutine write_meta(unit, field, meta_name, meta_value) +! integer, intent(out) :: unit !< unit id of an open file or -1 on a +! !! nonwriting PE with single file output +! type(fieldtype), intent(in) :: field !< fieldtype for the variable that meta data should be added +! character(len=*), intent(in) :: meta_name !< name of meta data to be added +! integer(kind=8), intent(in) :: meta_value !< value of meta data corresponding to meta_name +! +! character(len=64) :: meta_char +! +! write (meta_char,'(Z16)') meta_value +! call mpp_write_meta( unit, field%id, trim(meta_name), cval=meta_char ) +! +!end subroutine write_meta + !> \namespace mom_io diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 4dfe0fd456..e5c91021d7 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -57,6 +57,9 @@ module MOM_restart use MOM_time_manager, only : time_type, get_time, get_date, set_date, set_time use MOM_time_manager, only : days_in_month use MOM_verticalGrid, only : verticalGrid_type +use mpp_mod, only: mpp_chksum +use mpp_io_mod, only: mpp_attribute_exist, mpp_get_atts +use mpp_domains_mod, only: mpp_get_domain_shift implicit none ; private @@ -737,6 +740,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) real :: restart_time character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs integer :: length + integer(kind=8) :: check_val(CS%max_fields,1), checksum + integer :: iadd,jadd,ishift, jshift, pos + integer :: isL,ieL,jsL,jeL,sizes(7) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") @@ -837,12 +843,52 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) if (t_grid(1:1) /= 'p') & call modify_vardesc(vars(1), t_grid='s', caller="save_restart") + !Prepare the checksum of the restart fields to be written to restart files + do m=start_var,next_var-1 + call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, caller="save_restart") + select case (hor_grid) + case ('q') ; pos = CORNER + case ('h') ; pos = CENTER + case ('u') ; pos = EAST_FACE + case ('v') ; pos = NORTH_FACE + case ('Bu') ; pos = CORNER + case ('T') ; pos = CENTER + case ('Cu') ; pos = EAST_FACE + case ('Cv') ; pos = NORTH_FACE + case ('1') ; pos = 0 + case default ; pos = 0 + end select + call mpp_get_domain_shift(G%Domain%mpp_domain, ishift, jshift, pos) + iadd = G%iec-G%isc ! Size of the i-dimension on this processor (-1 as it is an increment) + jadd = G%jec-G%jsc ! Size of the j-dimension on this processor + if(G%iec == G%ieg) iadd = iadd + ishift + if(G%jec == G%jeg) jadd = jadd + jshift + isL=G%isc-G%isd+1 + ieL=G%iec-G%isd+1 + jsL=G%jsc-G%jsd+1 + jeL=G%jec-G%jsd+1 +! call get_file_atts(CS%restart_field(m)%vars,siz=sizes) +! call get_MOM_compute_domain(G,sizes,pos,isL,ieL,jsL,jeL) + + if (ASSOCIATED(CS%var_ptr3d(m)%p)) then + check_val(m,1) = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + elseif (ASSOCIATED(CS%var_ptr2d(m)%p)) then + check_val(m,1) = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + elseif (ASSOCIATED(CS%var_ptr4d(m)%p)) then + check_val(m,1) = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + elseif (ASSOCIATED(CS%var_ptr1d(m)%p)) then + check_val(m,1) = mpp_chksum(CS%var_ptr1d(m)%p) + elseif (ASSOCIATED(CS%var_ptr0d(m)%p)) then + check_val(m,1) = mpp_chksum(CS%var_ptr0d(m)%p) + endif + enddo + if (CS%parallel_restartfiles) then call create_file(unit, trim(restartpath), vars, (next_var-start_var), & - fields, MULTIPLE, G=G, GV=GV) + fields, MULTIPLE, G=G, GV=GV, checksums=check_val) else call create_file(unit, trim(restartpath), vars, (next_var-start_var), & - fields, SINGLE_FILE, G=G, GV=GV) + fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val) endif do m=start_var,next_var-1 @@ -902,7 +948,7 @@ subroutine restore_state(filename, directory, day, G, CS) character(len=80) :: fname ! The name of the current file. character(len=8) :: suffix ! A suffix (like "_2") that is added to any ! additional restart files. - character(len=256) :: mesg ! A message for warnings. + character(len=512) :: mesg ! A message for warnings. character(len=80) :: varname ! A variable's name. integer :: num_file ! The number of files (restart files and others ! explicitly in filename) that are open. @@ -919,7 +965,11 @@ subroutine restore_state(filename, directory, day, G, CS) real :: t1, t2 ! Two times. real, allocatable :: time_vals(:) type(fieldtype), allocatable :: fields(:) - + logical,parameter :: checksum_required = .true. + logical :: check_exist, is_there_a_checksum + integer(kind=8),dimension(1) :: checksum_file + integer(kind=8) :: checksum_data + integer :: iadd,jadd,ishift, jshift if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "restore_state: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -1005,39 +1055,68 @@ subroutine restore_state(filename, directory, day, G, CS) case default ; pos = 0 end select + call mpp_get_domain_shift(G%Domain%mpp_domain, ishift, jshift, pos) + iadd = G%iec-G%isc ! Size of the i-dimension on this processor (-1 as it is an increment) + jadd = G%jec-G%jsc ! Size of the j-dimension on this processor + if(G%iec == G%ieg) iadd = iadd + ishift + if(G%jec == G%jeg) jadd = jadd + jshift + isL=G%isc-G%isd+1 + ieL=G%iec-G%isd+1 + jsL=G%jsc-G%jsd+1 + jeL=G%jec-G%jsd+1 + do i=1, nvar call get_file_atts(fields(i),name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then + check_exist = mpp_attribute_exist(fields(i),"checksum") + checksum_file = -1 + checksum_data = -1 + is_there_a_checksum = .false. + if ( check_exist ) then + call mpp_get_atts(fields(i),checksum=checksum_file) + is_there_a_checksum = .true. + endif + if (.NOT. checksum_required ) is_there_a_checksum = .false. ! Do not need to do data checksumming. + + if (ASSOCIATED(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. call read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & no_domain=.true., timelevel=1) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr1d(m)%p) elseif (ASSOCIATED(CS%var_ptr0d(m)%p)) then ! Read a scalar... call read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & no_domain=.true., timelevel=1) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr0d(m)%p) elseif ((pos == 0) .and. ASSOCIATED(CS%var_ptr2d(m)%p)) then ! Read a non-decomposed 2d array. ! Probably should query the field type to make sure that the sizes are right. call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & no_domain=.true., timelevel=1) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) elseif ((pos == 0) .and. ASSOCIATED(CS%var_ptr3d(m)%p)) then ! Read a non-decomposed 3d array. ! Probably should query the field type to make sure that the sizes are right. call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & no_domain=.true., timelevel=1) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) elseif ((pos == 0) .and. ASSOCIATED(CS%var_ptr4d(m)%p)) then ! Read a non-decomposed 4d array. ! Probably should query the field type to make sure that the sizes are right. call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & no_domain=.true., timelevel=1) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) elseif (unit_is_global(n) .or. G%Domain%use_io_layout) then if (ASSOCIATED(CS%var_ptr3d(m)%p)) then ! Read 3d array... Time level 1 is always used. call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & G%Domain, 1, position=pos) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) elseif (ASSOCIATED(CS%var_ptr2d(m)%p)) then ! Read 2d array... call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & G%Domain, 1, position=pos) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) elseif (ASSOCIATED(CS%var_ptr4d(m)%p)) then ! Read 4d array... call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & G%Domain, 1, position=pos) + if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) else call MOM_error(FATAL, "MOM_restart restore_state: "//& "No pointers set for "//trim(varname)) @@ -1110,12 +1189,23 @@ subroutine restore_state(filename, directory, day, G, CS) "No pointers set for "//trim(varname)) endif endif + + if(is_root_pe()) write(*,'(a,Z16,a,Z16)') "Checksums of input field "// trim(varname)//" ",checksum_data," ", checksum_file(1) + if(is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then + write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& + " does not match value ", checksum_file(1), & + " stored in "//trim(unit_path(n)//"." ) + call MOM_error(WARNING, "MOM_restart(restore_state): "//trim(mesg) ) + endif + CS%restart_field(m)%initialized = .true. exit ! Start search for next restart variable. - endif - enddo + + endif + + enddo if (i>nvar) missing_fields = missing_fields+1 - enddo + enddo deallocate(fields) if (missing_fields == 0) exit @@ -1460,4 +1550,41 @@ subroutine restart_error(CS) endif end subroutine restart_error +subroutine get_MOM_compute_domain(G,sizes,pos,isL,ieL,jsL,jeL) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer , intent(in) :: sizes(:),pos + integer , intent(out):: isL,ieL,jsL,jeL + integer :: is0,js0 + ! NOTE: The index ranges f var_ptrs always start with 1, so with + ! symmetric memory the staggering is swapped from NE to SW! + is0 = 1-G%isd + if ((pos == EAST_FACE) .or. (pos == CORNER)) is0 = 1-G%IsdB + if (sizes(1) == G%iec-G%isc+1) then + isL = G%isc+is0 ; ieL = G%iec+is0 + elseif (sizes(1) == G%IecB-G%IscB+1) then + isL = G%IscB+is0 ; ieL = G%IecB+is0 + elseif (((pos == EAST_FACE) .or. (pos == CORNER)) .and. & + (G%IscB == G%isc) .and. (sizes(1) == G%iec-G%isc+2)) then + ! This is reading a symmetric file in a non-symmetric model. + isL = G%isc-1+is0 ; ieL = G%iec+is0 + else + call MOM_error(WARNING, "MOM_restart restore_state, i-size ") + endif + + js0 = 1-G%jsd + if ((pos == NORTH_FACE) .or. (pos == CORNER)) js0 = 1-G%JsdB + if (sizes(2) == G%jec-G%jsc+1) then + jsL = G%jsc+js0 ; jeL = G%jec+js0 + elseif (sizes(2) == G%jecB-G%jscB+1) then + jsL = G%jscB+js0 ; jeL = G%jecB+js0 + elseif (((pos == NORTH_FACE) .or. (pos == CORNER)) .and. & + (G%JscB == G%jsc) .and. (sizes(2) == G%jec-G%jsc+2)) then + ! This is reading a symmetric file in a non-symmetric model. + jsL = G%jsc-1+js0 ; jeL = G%jec+js0 + else + call MOM_error(WARNING, "MOM_restart restore_state, wrong j-size ") + endif + +end subroutine get_MOM_compute_domain + end module MOM_restart From bffccd69d2da85288f906c402d27d4e782aaff19 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jan 2018 20:46:02 -0500 Subject: [PATCH 114/170] Added missing trim() to argument for _zold diagnostic - A `trim()` was needed before attaching "_xyave" to a field name inside the old z-diagnostics package. --- src/diagnostics/MOM_diag_to_Z.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diag_to_Z.F90 b/src/diagnostics/MOM_diag_to_Z.F90 index 1612bdc90e..43f39c4e16 100644 --- a/src/diagnostics/MOM_diag_to_Z.F90 +++ b/src/diagnostics/MOM_diag_to_Z.F90 @@ -1002,7 +1002,7 @@ subroutine register_Z_tracer_low(tr_ptr, name, long_name, units, standard_name, CS%id_tr(m) = register_diag_field('ocean_model_zold', name, CS%axesTz, Time, & long_name, units, missing_value=CS%missing_tr(m), & standard_name=standard_name) - CS%id_tr_xyave(m) = register_diag_field('ocean_model_zold', name//'_xyave', CS%axesZ, Time, & + CS%id_tr_xyave(m) = register_diag_field('ocean_model_zold', trim(name)//'_xyave', CS%axesZ, Time, & long_name, units, missing_value=CS%missing_tr(m), & standard_name=standard_name) else From 88262c8d045e8531821ad399efe0d57cd2cd0add Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 18 Jan 2018 10:41:45 -0900 Subject: [PATCH 115/170] Go without logging of SEGMENT_DATA stuff for now. --- src/core/MOM_open_boundary.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index b05bebb87b..76351ede45 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -489,8 +489,10 @@ subroutine initialize_segment_data(G, OBC, PF) write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n write(suffix,"('_segment_',i3.3)") n - ! needs documentation !! - call get_param(PF, mdl, segnam, segstr, 'xyz') + ! needs documentation !! Yet, unsafe for now, causes grief for + ! MOM_parameter_docs in circle_obcs on two processes. +! call get_param(PF, mdl, segnam, segstr, 'xyz') + call get_param(PF, mdl, segnam, segstr) call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) if (num_fields == 0) then From f34de7350a1f5e7ec67631c9d45fec346751907a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Jan 2018 16:34:50 -0500 Subject: [PATCH 116/170] +Modified interface to register_tracer Modified the interface to register_tracer to permit the metadata to be passed in as individual arguments, bypassing the need to convert some data into a vardesc type first. Because the order and nature of some of the arguments change, all tracer routines need to be modified at the same time. All answers and diagnostics are bitwise identical, but this interface change does not permit backward compatibility. --- src/core/MOM.F90 | 19 +-- src/tracer/DOME_tracer.F90 | 6 +- src/tracer/ISOMIP_tracer.F90 | 6 +- src/tracer/MOM_OCMIP2_CFC.F90 | 8 +- src/tracer/MOM_generic_tracer.F90 | 4 +- src/tracer/MOM_tracer_registry.F90 | 156 ++++++++++++++----------- src/tracer/advection_test_tracer.F90 | 6 +- src/tracer/boundary_impulse_tracer.F90 | 5 +- src/tracer/dye_example.F90 | 11 +- src/tracer/dyed_obc_tracer.F90 | 6 +- src/tracer/ideal_age_example.F90 | 5 +- src/tracer/oil_tracer.F90 | 5 +- src/tracer/pseudo_salt_tracer.F90 | 9 +- src/tracer/tracer_example.F90 | 6 +- 14 files changed, 140 insertions(+), 112 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7262fc3b94..1ecda0351e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1853,13 +1853,13 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo conv2salt = GV%H_to_kg_m2 H_convert = GV%H_to_kg_m2 endif - call register_tracer(CS%tv%T, CS%vd_T, param_file, dG%HI, GV, CS%tracer_Reg, & - CS%vd_T, registry_diags=.true., flux_nameroot='T', & + call register_tracer(CS%tv%T, CS%tracer_Reg, param_file, dG%HI, GV, & + tr_desc=CS%vd_T, registry_diags=.true., flux_nameroot='T', & flux_units='W m-2', flux_longname='Heat', & flux_scale=conv2watt, convergence_units='W m-2', & convergence_scale=conv2watt, CMOR_tendname="opottemptend", diag_form=2) - call register_tracer(CS%tv%S, CS%vd_S, param_file, dG%HI, GV, CS%tracer_Reg, & - CS%vd_S, registry_diags=.true., flux_nameroot='S', & + call register_tracer(CS%tv%S, CS%tracer_Reg, param_file, dG%HI, GV, & + tr_desc=CS%vd_S, registry_diags=.true., flux_nameroot='S', & flux_units=S_flux_units, flux_longname='Salt', & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendname="osalttend", diag_form=2) @@ -2445,7 +2445,6 @@ subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS, IDs, diag) type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output integer :: isd, ied, jsd, jed, nz - type(vardesc) :: vd_tmp isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -2456,8 +2455,9 @@ subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS, IDs, diag) call safe_alloc_ptr(CS%T_squared,isd,ied,jsd,jed,nz) CS%T_squared(:,:,:) = 0. - vd_tmp = var_desc(name="T2", units="degC2", longname="Squared Potential Temperature") - call register_tracer(CS%T_squared, vd_tmp, param_file, HI, GV, CS%tracer_reg) + call register_tracer(CS%T_squared, CS%tracer_reg, param_file, HI, GV, & + name="T2", units="degC2", longname="Squared Potential Temperature", & + registry_diags=.false.) endif IDs%id_S_vardec = register_diag_field('ocean_model', 'S_vardec', diag%axesTL, Time, & @@ -2466,8 +2466,9 @@ subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS, IDs, diag) call safe_alloc_ptr(CS%S_squared,isd,ied,jsd,jed,nz) CS%S_squared(:,:,:) = 0. - vd_tmp = var_desc(name="S2", units="psu2", longname="Squared Salinity") - call register_tracer(CS%S_squared, vd_tmp, param_file, HI, GV, CS%tracer_reg) + call register_tracer(CS%S_squared, CS%tracer_reg, param_file, HI, GV, & + name="S2", units="psu2", longname="Squared Salinity", & + registry_diags=.false.) endif end subroutine register_diags_TS_vardec diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 58a6c47cd0..6ee2df6cec 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -122,9 +122,9 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Register the tracer for the restart file. call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - flux_units=flux_units) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 44dc2a4276..4dc9d55c4b 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -138,9 +138,9 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, & ! Register the tracer for the restart file. call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - flux_units=flux_units) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 82e3fe11eb..890ac7ad9d 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -216,15 +216,15 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) call register_restart_field(tr_ptr, CS%CFC11_desc, & .not.CS%tracers_may_reinit, restart_CS) ! Register CFC11 for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%CFC11_desc, param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%CFC11_desc, registry_diags=.true., & + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + tr_desc=CS%CFC11_desc, registry_diags=.true., & flux_units=flux_units) ! Do the same for CFC12 tr_ptr => CS%CFC12 call register_restart_field(tr_ptr, CS%CFC12_desc, & .not.CS%tracers_may_reinit, restart_CS) - call register_tracer(tr_ptr, CS%CFC12_desc, param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%CFC12_desc, registry_diags=.true., & + call register_tracer(tr_ptr, Tr_Reg, param_file, HI, GV, & + tr_desc=CS%CFC12_desc, registry_diags=.true., & flux_units=flux_units) ! Set and read the various empirical coefficients. diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 113c8712c7..6ff001d64b 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -209,7 +209,9 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! the vardesc type, a pointer to this type can not be set as a target ! for register_tracer to use. if (g_tracer_is_prog(g_tracer)) & - call register_tracer(tr_ptr, vdesc, param_file, HI, GV, tr_Reg) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=g_tracer_name, longname=longname, units=units, & + registry_diags=.false.) !### CHANGE TO TRUE? !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 6ec2c89d0f..36b9e738fa 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -61,9 +61,14 @@ module MOM_tracer_registry !! at a previous timestep used for diagnostics character(len=32) :: name !< tracer name used for diagnostics and error messages - type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer + character(len=64) :: units !< Physical dimensions of the variable + character(len=240) :: longname !< Long name of the variable +! type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer logical :: registry_diags = .false. !< If true, use the registry to set up the !! diagnostics associated with this tracer. + character(len=64) :: cmor_name !< CMOR name of this tracer + character(len=64) :: cmor_units !< CMOR physical dimensions of the tracer + character(len=240) :: cmor_longname !< CMOR long name of the tracer character(len=32) :: flux_nameroot = "" !< Short tracer name snippet used construct the !! names of flux diagnostics. character(len=64) :: flux_longname = "" !< A word or phrase used construct the long @@ -92,7 +97,7 @@ module MOM_tracer_registry type(tracer_type) :: Tr(MAX_FIELDS_) !< array of registered tracers ! type(diag_ctrl), pointer :: diag !< structure to regulate timing of diagnostics logical :: locked = .false. !< New tracers may be registered if locked=.false. - !! When locked=.true.,no more tracers can be registered, + !! When locked=.true., no more tracers can be registered, !! at which point common diagnostics can be set up !! for the registered tracers. end type tracer_registry_type @@ -100,27 +105,25 @@ module MOM_tracer_registry contains !> This subroutine registers a tracer to be advected and laterally diffused. -subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, ad_x, ad_y,& - df_x, df_y, OBC_inflow, OBC_in_u, OBC_in_v, & +subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, units, & + cmor_name, cmor_units, cmor_longname, tr_desc, & + OBC_inflow, OBC_in_u, OBC_in_v, ad_x, ad_y, df_x, df_y, & ad_2d_x, ad_2d_y, df_2d_x, df_2d_y, advection_xy, registry_diags, & flux_nameroot, flux_longname, flux_units, flux_scale, & convergence_units, convergence_scale, cmor_tendname, diag_form) type(hor_index_type), intent(in) :: HI !< horizontal index type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), target :: tr1 !< pointer to the tracer (concentration units) - type(vardesc), intent(in) :: tr_desc !< metadata about the tracer - type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values - type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry - type(vardesc), target, optional :: tr_desc_ptr !< A target that can be used to set a pointer to the - !! stored value of tr%tr_desc. This target must be an - !! enduring part of the control structure, because the tracer - !! registry will use this memory, but it also means that any - !! updates to this structure in the calling module will be - !! available subsequently to the tracer registry. - real, pointer, dimension(:,:,:), optional :: ad_x !< diagnostic x-advective flux (CONC m3/s or CONC*kg/s) - real, pointer, dimension(:,:,:), optional :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) - real, pointer, dimension(:,:,:), optional :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) - real, pointer, dimension(:,:,:), optional :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & + target :: tr_ptr !< target or pointer to the tracer array + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), optional, intent(in) :: name !< Short tracer name + character(len=*), optional, intent(in) :: longname !< The long tracer name + character(len=*), optional, intent(in) :: units !< The units of this tracer + character(len=*), optional, intent(in) :: cmor_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + type(vardesc), optional, intent(in) :: tr_desc !< A structure with metadata about the tracer real, intent(in), optional :: OBC_inflow !< the tracer for all inflows via OBC for which OBC_in_u !! or OBC_in_v are not specified (units of tracer CONC) @@ -129,6 +132,11 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a real, pointer, dimension(:,:,:), optional :: OBC_in_v !< tracer at inflows through v-faces of !! tracer cells (units of tracer CONC) + ! The following are probably not necessary if registry_diags is present and true. + real, pointer, dimension(:,:,:), optional :: ad_x !< diagnostic x-advective flux (CONC m3/s or CONC*kg/s) + real, pointer, dimension(:,:,:), optional :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) + real, pointer, dimension(:,:,:), optional :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) + real, pointer, dimension(:,:,:), optional :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) real, dimension(:,:), pointer, optional :: ad_2d_x !< vert sum of diagnostic x-advect flux (CONC m3/s or CONC*kg/s) real, dimension(:,:), pointer, optional :: ad_2d_y !< vert sum of diagnostic y-advect flux (CONC m3/s or CONC*kg/s) real, dimension(:,:), pointer, optional :: df_2d_x !< vert sum of diagnostic x-diffuse flux (CONC m3/s or CONC*kg/s) @@ -150,9 +158,7 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a character(len=*), optional, intent(in) :: cmor_tendname !< The CMOR name for the layer-integrated tendencies of this tracer. integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the character !! string template to use in labeling diagnostics - integer :: ntr - type(tracer_type) :: temp - character(len=72) :: longname ! The long name of a variable. + type(tracer_type), pointer :: Tr=>NULL() character(len=256) :: mesg ! Message for error messages. if (.not. associated(Reg)) call tracer_registry_init(param_file, Reg) @@ -163,72 +169,89 @@ subroutine register_tracer(tr1, tr_desc, param_file, HI, GV, Reg, tr_desc_ptr, a call MOM_error(FATAL,"MOM register_tracer: "//mesg) endif Reg%ntr = Reg%ntr + 1 - ntr = Reg%ntr - if (present(tr_desc_ptr)) then - Reg%Tr(ntr)%vd => tr_desc_ptr + Tr => Reg%Tr(Reg%ntr) + + if (present(name)) then + Tr%name = name + Tr%longname = name ; if (present(longname)) Tr%longname = longname + Tr%units = "Conc" ; if (present(units)) Tr%units = units + + Tr%cmor_name = "" + if (present(cmor_name)) Tr%cmor_name = cmor_name + + Tr%cmor_units = Tr%units + if (present(cmor_units)) Tr%cmor_units = cmor_units + + Tr%cmor_longname = "" + if (present(cmor_longname)) Tr%cmor_longname = cmor_longname + + if (present(tr_desc)) call MOM_error(WARNING, "MOM register_tracer: "//& + "It is a bad idea to use both name and tr_desc when registring "//trim(name)) + elseif (present(tr_desc)) then + call query_vardesc(tr_desc, name=Tr%name, units=Tr%units, & + longname=Tr%longname, cmor_field_name=Tr%cmor_name, & + cmor_longname=Tr%cmor_longname, caller="register_tracer") + Tr%cmor_units = Tr%units else - allocate(Reg%Tr(ntr)%vd) ; Reg%Tr(ntr)%vd = tr_desc + call MOM_error(FATAL,"MOM register_tracer: Either name or "//& + "tr_desc must be present when registering a tracer.") endif - call query_vardesc(Reg%Tr(ntr)%vd, name=Reg%Tr(ntr)%name, longname=longname) - if (Reg%locked) call MOM_error(FATAL, & - "MOM register_tracer was called for variable "//trim(Reg%Tr(ntr)%name)//& + "MOM register_tracer was called for variable "//trim(Tr%name)//& " with a locked tracer registry.") - Reg%Tr(ntr)%flux_nameroot = Reg%Tr(ntr)%name + Tr%flux_nameroot = Tr%name if (present(flux_nameroot)) then - if (len_trim(flux_nameroot) > 0) Reg%Tr(ntr)%flux_nameroot = flux_nameroot + if (len_trim(flux_nameroot) > 0) Tr%flux_nameroot = flux_nameroot endif - Reg%Tr(ntr)%flux_longname = longname + Tr%flux_longname = Tr%longname if (present(flux_longname)) then - if (len_trim(flux_longname) > 0) Reg%Tr(ntr)%flux_longname = flux_longname + if (len_trim(flux_longname) > 0) Tr%flux_longname = flux_longname endif - Reg%Tr(ntr)%flux_units = "" - if (present(flux_units)) Reg%Tr(ntr)%flux_units = flux_units + Tr%flux_units = "" + if (present(flux_units)) Tr%flux_units = flux_units - Reg%Tr(ntr)%flux_scale = 1.0 - if (present(flux_scale)) Reg%Tr(ntr)%flux_scale = flux_scale + Tr%flux_scale = 1.0 + if (present(flux_scale)) Tr%flux_scale = flux_scale - Reg%Tr(ntr)%conv_units = "" - if (present(convergence_units)) Reg%Tr(ntr)%conv_units = convergence_units + Tr%conv_units = "" + if (present(convergence_units)) Tr%conv_units = convergence_units - Reg%Tr(ntr)%cmor_tendname = "" - if (present(cmor_tendname)) Reg%Tr(ntr)%cmor_tendname = cmor_tendname + Tr%cmor_tendname = "" + if (present(cmor_tendname)) Tr%cmor_tendname = cmor_tendname - Reg%Tr(ntr)%conv_scale = 1.0 + Tr%conv_scale = 1.0 if (present(convergence_scale)) then - Reg%Tr(ntr)%conv_scale = convergence_scale + Tr%conv_scale = convergence_scale elseif (present(flux_scale)) then - Reg%Tr(ntr)%conv_scale = flux_scale + Tr%conv_scale = flux_scale endif - Reg%Tr(ntr)%diag_form = 1 - if (present(diag_form)) Reg%Tr(ntr)%diag_form = diag_form + Tr%diag_form = 1 + if (present(diag_form)) Tr%diag_form = diag_form + + Tr%t => tr_ptr - Reg%Tr(ntr)%t => tr1 + if (present(registry_diags)) Tr%registry_diags = registry_diags - if (present(ad_x)) then ; if (associated(ad_x)) Reg%Tr(ntr)%ad_x => ad_x ; endif - if (present(ad_y)) then ; if (associated(ad_y)) Reg%Tr(ntr)%ad_y => ad_y ; endif - if (present(df_x)) then ; if (associated(df_x)) Reg%Tr(ntr)%df_x => df_x ; endif - if (present(df_y)) then ; if (associated(df_y)) Reg%Tr(ntr)%df_y => df_y ; endif - if (present(OBC_inflow)) Reg%Tr(ntr)%OBC_inflow_conc = OBC_inflow + if (present(ad_x)) then ; if (associated(ad_x)) Tr%ad_x => ad_x ; endif + if (present(ad_y)) then ; if (associated(ad_y)) Tr%ad_y => ad_y ; endif + if (present(df_x)) then ; if (associated(df_x)) Tr%df_x => df_x ; endif + if (present(df_y)) then ; if (associated(df_y)) Tr%df_y => df_y ; endif + if (present(OBC_inflow)) Tr%OBC_inflow_conc = OBC_inflow if (present(OBC_in_u)) then ; if (associated(OBC_in_u)) & - Reg%Tr(ntr)%OBC_in_u => OBC_in_u ; endif + Tr%OBC_in_u => OBC_in_u ; endif if (present(OBC_in_v)) then ; if (associated(OBC_in_v)) & - Reg%Tr(ntr)%OBC_in_v => OBC_in_v ; endif - if (present(ad_2d_x)) then ; if (associated(ad_2d_x)) Reg%Tr(ntr)%ad2d_x => ad_2d_x ; endif - if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Reg%Tr(ntr)%ad2d_y => ad_2d_y ; endif - if (present(df_2d_x)) then ; if (associated(df_2d_x)) Reg%Tr(ntr)%df2d_x => df_2d_x ; endif + Tr%OBC_in_v => OBC_in_v ; endif + if (present(ad_2d_x)) then ; if (associated(ad_2d_x)) Tr%ad2d_x => ad_2d_x ; endif + if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Tr%ad2d_y => ad_2d_y ; endif + if (present(df_2d_x)) then ; if (associated(df_2d_x)) Tr%df2d_x => df_2d_x ; endif - if (present(advection_xy)) then ; if (associated(advection_xy)) Reg%Tr(ntr)%advection_xy => advection_xy ; endif - - if (present(registry_diags)) then - Reg%Tr(ntr)%registry_diags = registry_diags - endif + if (present(advection_xy)) then ; if (associated(advection_xy)) Tr%advection_xy => advection_xy ; endif end subroutine register_tracer @@ -366,9 +389,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) - call query_vardesc(Tr%vd, name, units=units, longname=longname, & - cmor_field_name=cmorname, cmor_longname=cmor_longname, & - caller="register_tracer_diagnostics") +! call query_vardesc(Tr%vd, name, units=units, longname=longname, & +! cmor_field_name=cmorname, cmor_longname=cmor_longname, & +! caller="register_tracer_diagnostics") + name = Tr%name ; units=Tr%units ; longname = Tr%longname + cmorname = Tr%cmor_name ; cmor_longname = Tr%cmor_longname shortnm = Tr%flux_nameroot flux_longname = Tr%flux_longname if (len_trim(cmor_longname) == 0) cmor_longname = longname @@ -387,7 +412,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) else Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & Time, trim(longname), trim(units), cmor_field_name=cmorname, & - cmor_standard_name=cmor_long_std(cmor_longname), cmor_long_name=cmor_longname) + cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & + cmor_standard_name=cmor_long_std(cmor_longname)) endif if (Tr%diag_form == 1) then Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 23b6164449..0389c3a04c 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -187,9 +187,9 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ call register_restart_field(tr_ptr, CS%tr_desc(m), & .not. CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - flux_units=flux_units) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index c13b0957b4..6031c361a5 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -138,9 +138,8 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar call register_restart_field(tr_ptr, CS%tr_desc(m), & .not. CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - flux_units=flux_units) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & + registry_diags=.true., flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index a3ed80a2e0..135346fd79 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -148,15 +148,14 @@ function register_dye_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) if (minval(CS%dye_source_maxdepth(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXDEPTH ") + + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 + do m = 1, CS%ntr write(var_name(:),'(A,I3.3)') "dye",m write(desc_name(:),'(A,I3.3)') "Dye Tracer ",m CS%tr_desc(m) = var_desc(trim(var_name), "conc", trim(desc_name), caller=mdl) - enddo - allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 - - do m=1,CS%ntr ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) @@ -166,8 +165,8 @@ function register_dye_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call register_restart_field(tr_ptr, CS%tr_desc(m), & .not.CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true.) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + tr_desc=CS%tr_desc(m), registry_diags=.true.) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 1d18777a26..71bd127250 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -121,9 +121,9 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Register the tracer for the restart file. call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - flux_units=flux_units) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 4102c0e0e1..1e6123af5f 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -224,9 +224,8 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call register_restart_field(tr_ptr, CS%tr_desc(m), & .not.CS%tracers_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - diag_form=1) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & + registry_diags=.true.) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 2c167c11d6..784d4f7c0a 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -231,9 +231,8 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call register_restart_field(tr_ptr, CS%tr_desc(m), & .not.CS%oil_may_reinit, restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - flux_units=flux_units) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & + registry_diags=.true., flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 2328b56934..29af0d3812 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -139,9 +139,12 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Register the tracer for the restart file. call register_restart_field(tr_ptr, CS%tr_desc, & .not. CS%pseudo_salt_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc, param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc, registry_diags=.true.) + ! Register the tracer for horizontal advection & diffusion. For now, either form works. +! call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & +! tr_desc=CS%tr_desc, registry_diags=.true.) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, name="pseudo_salt", & + longname="Pseudo salt passive tracer", units="psu", & + registry_diags=.true.) CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index d88969be6b..c20c44e443 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -155,9 +155,9 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! Register the tracer for the restart file. call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, CS%tr_desc(m), param_file, HI, GV, tr_Reg, & - tr_desc_ptr=CS%tr_desc(m), registry_diags=.true., & - flux_units=flux_units) + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=name, longname=longname, units="kg kg-1", & + registry_diags=.true., flux_units=flux_units) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will From d8c8269dec478b7615b0094cfbfdbc03a4400fc4 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 18 Jan 2018 13:33:05 -0900 Subject: [PATCH 117/170] Clean out commented EXTEND option. - Changed the text for setting OBC nudging timescales too. --- src/core/MOM_open_boundary.F90 | 38 ++-------------------------------- 1 file changed, 2 insertions(+), 36 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 76351ede45..39f1acf104 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -181,7 +181,6 @@ module MOM_open_boundary !! in the strain on open boundaries. logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for !! use in the biharmonic viscosity term. -! logical :: extend_segments = .false. !< If True, extend OBC segments (for testing) logical :: brushcutter_mode = .false. !< If True, read data on supergrid. real :: g_Earth ! Properties of the segments used. @@ -280,11 +279,6 @@ subroutine open_boundary_config(G, param_file, OBC) if (config1 .ne. "none") OBC%user_BCs_set_globally = .true. -! call get_param(param_file, mdl, "EXTEND_OBC_SEGMENTS", OBC%extend_segments, & -! "If true, extend OBC segments. This option is used to recover\n"//& -! "legacy solutions dependent on an incomplete implementaion of OBCs.\n"//& -! "This option will be obsoleted in the future.", default=.false.) - if (OBC%number_of_segments > 0) then call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & "If true, sets relative vorticity to zero on open boundaries.", & @@ -677,15 +671,6 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) Js_obc = Js_obc - G%jdg_offset ! Convert to local tile indices on this tile Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile - ! Hack to extend segment by one point -! if (OBC%extend_segments) then -! if (Js_obcJs_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_E else if (Je_obcIs_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_S else if (Ie_obc Date: Thu, 18 Jan 2018 18:42:59 -0500 Subject: [PATCH 118/170] +Overloaded interfaces to register_restart_field Added additional routines that are accessed overloaded interfaces to register_restart_field. These new interfaces allow metadata to be specified via a set of optional argument, rather than being externally packaged into a vardesc type. All answers (and restart files) are bitwise identical. --- src/framework/MOM_restart.F90 | 258 +++++++++++++++++++++++----------- 1 file changed, 177 insertions(+), 81 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 4dfe0fd456..dd01fec9d4 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -51,7 +51,7 @@ module MOM_restart use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file use MOM_io, only : read_field, write_field, MOM_read_data, read_data, get_filename_appendix use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times -use MOM_io, only : vardesc, query_vardesc, modify_vardesc +use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_time_manager, only : time_type, get_time, get_date, set_date, set_time @@ -121,11 +121,11 @@ module MOM_restart end type MOM_restart_CS interface register_restart_field - module procedure register_restart_field_ptr4d - module procedure register_restart_field_ptr3d - module procedure register_restart_field_ptr2d - module procedure register_restart_field_ptr1d - module procedure register_restart_field_ptr0d + module procedure register_restart_field_ptr4d, register_restart_field_4d + module procedure register_restart_field_ptr3d, register_restart_field_3d + module procedure register_restart_field_ptr2d, register_restart_field_2d + module procedure register_restart_field_ptr1d, register_restart_field_1d + module procedure register_restart_field_ptr0d, register_restart_field_0d end interface interface query_initialized @@ -139,22 +139,14 @@ module MOM_restart contains +!> Register a 3-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:,:), target :: f_ptr - type(vardesc), intent(in) :: var_desc - logical, intent(in) :: mandatory - type(MOM_restart_CS), pointer :: CS -! Set up a field that will be written to and read from restart -! files. -! -! Arguments: f_ptr - A pointer to the field to be read or written. -! (in) var_desc - The descriptive structure for the field. -! (in) mandatory - If .true. the run will abort if this field is not -! successfully read from the restart file. If .false., -! alternate techniques are provided to initialize this -! field if it is cannot be read from the file. -! (in/out) CS - The control structure returned by a previous call to -! restart_init. + real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -177,22 +169,14 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr3d +!> Register a 4-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:,:,:), target :: f_ptr - type(vardesc), intent(in) :: var_desc - logical, intent(in) :: mandatory - type(MOM_restart_CS), pointer :: CS -! Set up a field that will be written to and read from restart -! files. -! -! Arguments: f_ptr - A pointer to the field to be read or written. -! (in) var_desc - The descriptive structure for the field. -! (in) mandatory - If .true. the run will abort if this field is not -! successfully read from the restart file. If .false., -! alternate techniques are provided to initialize this -! field if it is cannot be read from the file. -! (in/out) CS - The control structure returned by a previous call to -! restart_init. + real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -215,22 +199,14 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr4d +!> Register a 2-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:), target :: f_ptr - type(vardesc), intent(in) :: var_desc - logical, intent(in) :: mandatory - type(MOM_restart_CS), pointer :: CS -! Set up a field that will be written to and read from restart -! files. -! -! Arguments: f_ptr - A pointer to the field to be read or written. -! (in) var_desc - The descriptive structure for the field. -! (in) mandatory - If .true. the run will abort if this field is not -! successfully read from the restart file. If .false., -! alternate techniques are provided to initialize this -! field if it is cannot be read from the file. -! (in/out) CS - The control structure returned by a previous call to -! restart_init. + real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -253,22 +229,14 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr2d +!> Register a 1-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) - real, dimension(:), target :: f_ptr - type(vardesc), intent(in) :: var_desc - logical, intent(in) :: mandatory - type(MOM_restart_CS), pointer :: CS -! Set up a field that will be written to and read from restart -! files. -! -! Arguments: f_ptr - A pointer to the field to be read or written. -! (in) var_desc - The descriptive structure for the field. -! (in) mandatory - If .true. the run will abort if this field is not -! successfully read from the restart file. If .false., -! alternate techniques are provided to initialize this -! field if it is cannot be read from the file. -! (in/out) CS - The control structure returned by a previous call to -! restart_init. + real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -291,22 +259,14 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr1d +!> Register a 0-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) - real, target :: f_ptr - type(vardesc), intent(in) :: var_desc - logical, intent(in) :: mandatory - type(MOM_restart_CS), pointer :: CS -! Set up a field that will be written to and read from restart -! files. -! -! Arguments: f_ptr - A pointer to the field to be read or written. -! (in) var_desc - The descriptive structure for the field. -! (in) mandatory - If .true. the run will abort if this field is not -! successfully read from the restart file. If .false., -! alternate techniques are provided to initialize this -! field if it is cannot be read from the file. -! (in/out) CS - The control structure returned by a previous call to -! restart_init. + real, target :: f_ptr !< A pointer to the field to be read or written + type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -329,6 +289,142 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr0d +! The following provide alternate interfaces to register restarts. + +!> Register a 4-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, & + hor_grid, z_grid, t_grid) + real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, 'h' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_4d: Module must be initialized before "//& + "it is used to register "//trim(name)) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + + call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS) + +end subroutine register_restart_field_4d + +!> Register a 3-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, & + hor_grid, z_grid, t_grid) + real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, 'h' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_3d: Module must be initialized before "//& + "it is used to register "//trim(name)) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + + call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS) + +end subroutine register_restart_field_3d + +!> Register a 2-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, & + hor_grid, z_grid, t_grid) + real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, 'h' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, '1' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + character(len=8) :: Zgrid + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_2d: Module must be initialized before "//& + "it is used to register "//trim(name)) + zgrid = '1' ; if (present(z_grid)) zgrid = z_grid + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=zgrid, t_grid=t_grid) + + call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS) + +end subroutine register_restart_field_2d + +!> Register a 1-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, & + hor_grid, z_grid, t_grid) + real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: hor_grid !< variable horizonal staggering, '1' if absent + character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + character(len=8) :: hgrid + + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_3d: Module must be initialized before "//& + "it is used to register "//trim(name)) + hgrid = '1' ; if (present(hor_grid)) hgrid = hor_grid + vd = var_desc(name, units=units, longname=longname, hor_grid=hgrid, & + z_grid=z_grid, t_grid=t_grid) + + call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS) + +end subroutine register_restart_field_1d + +!> Register a 0-d field for restarts, providing the metadata as individual arguments +subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, & + t_grid) + real, target :: f_ptr !< A pointer to the field to be read or written + character(len=*), intent(in) :: name !< variable name to be used in the restart file + logical, intent(in) :: mandatory !< If true, the run will abort if this field is not + !! successfully read from the restart file. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in/out) + character(len=*), optional, intent(in) :: longname !< variable long name + character(len=*), optional, intent(in) :: units !< variable units + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + + type(vardesc) :: vd + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & + "register_restart_field_0d: Module must be initialized before "//& + "it is used to register "//trim(name)) + vd = var_desc(name, units=units, longname=longname, hor_grid='1', & + z_grid='1', t_grid=t_grid) + + call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS) + +end subroutine register_restart_field_0d + + +!> query_initialized_name determines whether a named field has been successfully +!! read from a restart file yet. function query_initialized_name(name, CS) result(query_initialized) character(len=*) :: name type(MOM_restart_CS), pointer :: CS From 3a8c5f66a5cec5cf0cbe2797d7ce3e7c4f4938e2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Jan 2018 18:44:29 -0500 Subject: [PATCH 119/170] MOM.F90 uses new register_restart_field interfaces Modified the code in MOM.F90 to use the new name-based interfaces to register_restart_field. All answers are bitwise identical. --- src/core/MOM.F90 | 42 ++++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 1ecda0351e..7f588f987f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2290,8 +2290,8 @@ subroutine finish_MOM_initialization(Time, dirs, CS, fluxes) restart_CSp_tmp = CS%restart_CSp allocate(z_interface(SZI_(G),SZJ_(G),SZK_(G)+1)) call find_eta(CS%h, CS%tv, GV%g_Earth, G, GV, z_interface) - vd = var_desc("eta","meter","Interface heights",z_grid='i') - call register_restart_field(z_interface, vd, .true., restart_CSp_tmp) + call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & + "Interface heights", "meter", z_grid='i') call save_restart(dirs%output_directory, Time, G, & restart_CSp_tmp, filename=CS%IC_file, GV=GV) @@ -3046,7 +3046,6 @@ subroutine set_restart_fields(GV, param_file, CS) type(MOM_control_struct), intent(in) :: CS !< control structure set up by inialize_MOM ! Local variables logical :: use_ice_shelf ! Needed to determine whether to add CS%Hml to restarts - type(vardesc) :: vd character(len=48) :: thickness_units, flux_units call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., do_not_log=.true.) @@ -3055,39 +3054,38 @@ subroutine set_restart_fields(GV, param_file, CS) flux_units = get_flux_units(GV) if (CS%use_temperature) then - vd = var_desc("Temp","degC","Potential Temperature") - call register_restart_field(CS%tv%T, vd, .true., CS%restart_CSp) - - vd = var_desc("Salt","PPT","Salinity") - call register_restart_field(CS%tv%S, vd, .true., CS%restart_CSp) + call register_restart_field(CS%tv%T, "Temp", .true., CS%restart_CSp, & + "Potential Temperature", "degC") + call register_restart_field(CS%tv%S, "Salt", .true., CS%restart_CSp, & + "Salinity", "PPT") endif - vd = var_desc("h",thickness_units,"Layer Thickness") - call register_restart_field(CS%h, vd, .true., CS%restart_CSp) + call register_restart_field(CS%h, "h", .true., CS%restart_CSp, & + "Layer Thickness", thickness_units) - vd = var_desc("u","m s-1","Zonal velocity",'u','L') - call register_restart_field(CS%u, vd, .true., CS%restart_CSp) + call register_restart_field(CS%u, "u", .true., CS%restart_CSp, & + "Zonal velocity", "m s-1", hor_grid='Cu') - vd = var_desc("v","m s-1","Meridional velocity",'v','L') - call register_restart_field(CS%v, vd, .true., CS%restart_CSp) + call register_restart_field(CS%v, "v", .true., CS%restart_CSp, & + "Meridional velocity", "m s-1", hor_grid='Cv') if (CS%use_frazil) then - vd = var_desc("frazil","J m-2","Frazil heat flux into ocean",'h','1') - call register_restart_field(CS%tv%frazil, vd, .false., CS%restart_CSp) + call register_restart_field(CS%tv%frazil, "frazil", .false., CS%restart_CSp, & + "Frazil heat flux into ocean", "J m-2") endif if (CS%interp_p_surf) then - vd = var_desc("p_surf_prev","Pa","Previous ocean surface pressure",'h','1') - call register_restart_field(CS%p_surf_prev, vd, .false., CS%restart_CSp) + call register_restart_field(CS%p_surf_prev, "p_surf_prev", .false., CS%restart_CSp, & + "Previous ocean surface pressure", "Pa") endif - vd = var_desc("ave_ssh","meter","Time average sea surface height",'h','1') - call register_restart_field(CS%ave_ssh, vd, .false., CS%restart_CSp) + call register_restart_field(CS%ave_ssh, "ave_ssh", .false., CS%restart_CSp, & + "Time average sea surface height", "meter") ! hML is needed when using the ice shelf module if (use_ice_shelf .and. associated(CS%Hml)) then - vd = var_desc("hML","meter","Mixed layer thickness",'h','1') - call register_restart_field(CS%Hml, vd, .false., CS%restart_CSp) + call register_restart_field(CS%Hml, "hML", .false., CS%restart_CSp, & + "Mixed layer thickness", "meter") endif end subroutine set_restart_fields From 255ee4f38375d0cdb5dd27c777b718b80af6723a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Jan 2018 23:49:41 -0500 Subject: [PATCH 120/170] +Register tracer restarts via register_tracer Added the ability for register_tracer to also register the tracer with the restarts. All answers are bitwise identical, but there are new optional arguments to register_tracer. --- src/tracer/MOM_tracer_registry.F90 | 47 ++++++++++++++++++++---------- 1 file changed, 32 insertions(+), 15 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 36b9e738fa..2eefddd3c8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -16,6 +16,7 @@ module MOM_tracer_registry use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type use MOM_io, only : vardesc, query_vardesc, cmor_long_std +use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type use MOM_verticalGrid, only : verticalGrid_type @@ -110,7 +111,8 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit OBC_inflow, OBC_in_u, OBC_in_v, ad_x, ad_y, df_x, df_y, & ad_2d_x, ad_2d_y, df_2d_x, df_2d_y, advection_xy, registry_diags, & flux_nameroot, flux_longname, flux_units, flux_scale, & - convergence_units, convergence_scale, cmor_tendname, diag_form) + convergence_units, convergence_scale, cmor_tendname, diag_form, & + restart_CS, mandatory) type(hor_index_type), intent(in) :: HI !< horizontal index type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry @@ -125,24 +127,24 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name type(vardesc), optional, intent(in) :: tr_desc !< A structure with metadata about the tracer - real, intent(in), optional :: OBC_inflow !< the tracer for all inflows via OBC for which OBC_in_u + real, optional, intent(in) :: OBC_inflow !< the tracer for all inflows via OBC for which OBC_in_u !! or OBC_in_v are not specified (units of tracer CONC) - real, pointer, dimension(:,:,:), optional :: OBC_in_u !< tracer at inflows through u-faces of + real, dimension(:,:,:), optional, pointer :: OBC_in_u !< tracer at inflows through u-faces of !! tracer cells (units of tracer CONC) - real, pointer, dimension(:,:,:), optional :: OBC_in_v !< tracer at inflows through v-faces of + real, dimension(:,:,:), optional, pointer :: OBC_in_v !< tracer at inflows through v-faces of !! tracer cells (units of tracer CONC) ! The following are probably not necessary if registry_diags is present and true. - real, pointer, dimension(:,:,:), optional :: ad_x !< diagnostic x-advective flux (CONC m3/s or CONC*kg/s) - real, pointer, dimension(:,:,:), optional :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) - real, pointer, dimension(:,:,:), optional :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) - real, pointer, dimension(:,:,:), optional :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: ad_2d_x !< vert sum of diagnostic x-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: ad_2d_y !< vert sum of diagnostic y-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: df_2d_x !< vert sum of diagnostic x-diffuse flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: df_2d_y !< vert sum of diagnostic y-diffuse flux (CONC m3/s or CONC*kg/s) - - real, pointer, dimension(:,:,:), optional :: advection_xy !< convergence of lateral advective tracer fluxes + real, dimension(:,:,:), optional, pointer :: ad_x !< diagnostic x-advective flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux (CONC m3/s or CONC*kg/s) + + real, dimension(:,:,:), optional, pointer :: advection_xy !< convergence of lateral advective tracer fluxes logical, optional, intent(in) :: registry_diags !< If present and true, use the registry for !! the diagnostics of this tracer. character(len=*), optional, intent(in) :: flux_nameroot !< Short tracer name snippet used construct the @@ -150,7 +152,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit character(len=*), optional, intent(in) :: flux_longname !< A word or phrase used construct the long !! names of flux diagnostics. character(len=*), optional, intent(in) :: flux_units !< The units for the fluxes of this tracer. - real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes + real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes !! of this tracer to its desired units. character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of this tracer. real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux @@ -158,6 +160,13 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit character(len=*), optional, intent(in) :: cmor_tendname !< The CMOR name for the layer-integrated tendencies of this tracer. integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the character !! string template to use in labeling diagnostics + type(MOM_restart_CS), optional, pointer :: restart_CS !< A pointer to the restart control structure; + !! this tracer will be registered for + !! restarts if this argument is present + logical, optional, intent(in) :: mandatory !< If true, this tracer must be read + !! from a restart file. + + logical :: mand type(tracer_type), pointer :: Tr=>NULL() character(len=256) :: mesg ! Message for error messages. @@ -253,6 +262,14 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (present(advection_xy)) then ; if (associated(advection_xy)) Tr%advection_xy => advection_xy ; endif + if (present(restart_CS)) then ; if (associated(restart_CS)) then + ! Register this tracer to be read from and written to restart files. + mand = .true. ; if (present(mandatory)) mand = mandatory + + call register_restart_field(tr_ptr, Tr%name, mand, restart_CS, & + longname=Tr%longname, units=Tr%units) + endif ; endif + end subroutine register_tracer From 7c496bc708dae812bb959baa7f67817288755c68 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Jan 2018 23:53:01 -0500 Subject: [PATCH 121/170] Use tracer registry restarts for tracer packages Modified all of the tracer packages to register for restarts via the tracer registry. All answers are bitwise identical. --- src/tracer/DOME_tracer.F90 | 9 ++++----- src/tracer/ISOMIP_tracer.F90 | 9 ++++----- src/tracer/MOM_OCMIP2_CFC.F90 | 15 ++++++--------- src/tracer/MOM_generic_tracer.F90 | 23 +++++++---------------- src/tracer/advection_test_tracer.F90 | 10 ++++------ src/tracer/boundary_impulse_tracer.F90 | 15 ++++++--------- src/tracer/dye_example.F90 | 10 ++++------ src/tracer/dyed_obc_tracer.F90 | 9 ++++----- src/tracer/ideal_age_example.F90 | 10 ++++------ src/tracer/oil_tracer.F90 | 10 ++++------ src/tracer/pseudo_salt_tracer.F90 | 12 ++++-------- src/tracer/tracer_example.F90 | 9 ++++----- 12 files changed, 55 insertions(+), 86 deletions(-) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 6ee2df6cec..b4f19060a1 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -11,7 +11,7 @@ module DOME_tracer use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -119,12 +119,11 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=name, longname=longname, units="kg kg-1", & - registry_diags=.true., flux_units=flux_units) + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 4dc9d55c4b..599574d4d1 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -24,7 +24,7 @@ module ISOMIP_tracer use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : MOM_restart_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -135,12 +135,11 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, & ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=name, longname=longname, units="kg kg-1", & - registry_diags=.true., flux_units=flux_units) + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 890ac7ad9d..73090a71c9 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -56,7 +56,7 @@ module MOM_OCMIP2_CFC use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -212,20 +212,17 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This pointer assignment is needed to force the compiler not to do a copy in ! the registration calls. Curses on the designers and implementers of F90. tr_ptr => CS%CFC11 - ! Register CFC11 for the restart file. - call register_restart_field(tr_ptr, CS%CFC11_desc, & - .not.CS%tracers_may_reinit, restart_CS) - ! Register CFC11 for horizontal advection & diffusion. + ! Register CFC11 for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & tr_desc=CS%CFC11_desc, registry_diags=.true., & - flux_units=flux_units) + flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) ! Do the same for CFC12 tr_ptr => CS%CFC12 - call register_restart_field(tr_ptr, CS%CFC12_desc, & - .not.CS%tracers_may_reinit, restart_CS) call register_tracer(tr_ptr, Tr_Reg, param_file, HI, GV, & tr_desc=CS%CFC12_desc, registry_diags=.true., & - flux_units=flux_units) + flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) ! Set and read the various empirical coefficients. diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 6ff001d64b..e14c7074a4 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -113,7 +113,6 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) real, dimension(:,:,:), pointer :: tr_ptr real, dimension(HI%isd:HI%ied, HI%jsd:HI%jed,GV%ke) :: grid_tmask integer, dimension(HI%isd:HI%ied, HI%jsd:HI%jed) :: grid_kmt - type(vardesc) :: vdesc register_MOM_generic_tracer = .false. if (associated(CS)) then @@ -192,26 +191,18 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) - !nnz: Hard coded stuff. Need get/set routines - vdesc = var_desc(g_tracer_name, units, longname, & - caller="MOM_generic_tracer") !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? tr_ptr => tr_field(:,:,:,1) - ! Register tracer for restart file. - ! mandatory field in restart file is set to .false. - ! 2008/12/08 jgj: change default to true, so all fields must be present in restart. - ! 2010/02/04 jgj: if tracers_may_reinit is true, tracers may go through - ! initialization code if not found in restart - call register_restart_field(tr_ptr, vdesc, .not.CS%tracers_may_reinit, restart_CS) - - ! Register prognastic tracer for horizontal advection & diffusion. Note - ! that because the generic tracer code uses only a temporary copy of - ! the vardesc type, a pointer to this type can not be set as a target - ! for register_tracer to use. + ! Register prognastic tracer for horizontal advection, diffusion, and restarts. if (g_tracer_is_prog(g_tracer)) & call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=g_tracer_name, longname=longname, units=units, & - registry_diags=.false.) !### CHANGE TO TRUE? + registry_diags=.false., & !### CHANGE TO TRUE? + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + else + call register_restart_field(tr_ptr, name=g_tracer_name, .not.CS%tracers_may_reinit, & + restart_CS, longname=longname, units=units) + endif !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 0389c3a04c..d193476af7 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -45,7 +45,7 @@ module advection_test_tracer use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -183,13 +183,11 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), & - .not. CS%tracers_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=name, longname=longname, units="kg kg-1", & - registry_diags=.true., flux_units=flux_units) + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 6031c361a5..7dda599a52 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -134,12 +134,10 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar tr_ptr => CS%tr(:,:,:,m) call query_vardesc(CS%tr_desc(m), name=var_name, caller="register_boundary_impulse_tracer") - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), & - .not. CS%tracers_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & - registry_diags=.true., flux_units=flux_units) + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -150,10 +148,9 @@ function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restar enddo ! Register remaining source time as a restart field rem_time_ptr => CS%remaining_source_time - call register_restart_field(rem_time_ptr, & - var_desc(trim("bir_remain_time"), "s", "Remaining time to apply BIR source", & - hor_grid = "1", z_grid = "1", caller=mdl), & - .not. CS%tracers_may_reinit, restart_CS) + call register_restart_field(rem_time_ptr, "bir_remain_time", & + .not.CS%tracers_may_reinit, restart_CS, & + "Remaining time to apply BIR source", "s") CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 135346fd79..52a578c96a 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -11,7 +11,7 @@ module regional_dyes use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -161,12 +161,10 @@ function register_dye_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) tr_ptr => CS%tr(:,:,:,m) call query_vardesc(CS%tr_desc(m), name=var_name, & caller="register_dye_tracer") -! ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), & - .not.CS%tracers_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & - tr_desc=CS%tr_desc(m), registry_diags=.true.) + tr_desc=CS%tr_desc(m), registry_diags=.true., & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 71bd127250..f3e7563440 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -11,7 +11,7 @@ module dyed_obc_tracer use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : MOM_restart_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values @@ -118,12 +118,11 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=name, longname=longname, units="kg kg-1", & - registry_diags=.true., flux_units=flux_units) + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 1e6123af5f..91f410396d 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -46,7 +46,7 @@ module ideal_age_example use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -220,12 +220,10 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) tr_ptr => CS%tr(:,:,:,m) call query_vardesc(CS%tr_desc(m), name=var_name, & caller="register_ideal_age_tracer") - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), & - .not.CS%tracers_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & - registry_diags=.true.) + registry_diags=.true., restart_CS=restart_CS, & + mandatory=.not.CS%tracers_may_reinit) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 784d4f7c0a..7f97cfbedc 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -46,7 +46,7 @@ module oil_tracer use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -227,12 +227,10 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) call query_vardesc(CS%tr_desc(m), name=var_name, caller="register_oil_tracer") - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), & - .not.CS%oil_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, tr_desc=CS%tr_desc(m), & - registry_diags=.true., flux_units=flux_units) + registry_diags=.true., flux_units=flux_units, restart_CS=restart_CS, & + mandatory=.not.CS%oil_may_reinit) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 29af0d3812..fde068aa52 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -46,7 +46,7 @@ module pseudo_salt_tracer use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -136,15 +136,11 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) tr_ptr => CS%ps(:,:,:) call query_vardesc(CS%tr_desc, name=var_name, caller="register_pseudo_salt_tracer") - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc, & - .not. CS%pseudo_salt_may_reinit, restart_CS) - ! Register the tracer for horizontal advection & diffusion. For now, either form works. -! call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & -! tr_desc=CS%tr_desc, registry_diags=.true.) + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, name="pseudo_salt", & longname="Pseudo salt passive tracer", units="psu", & - registry_diags=.true.) + registry_diags=.true., restart_CS=restart_CS, & + mandatory=.not.CS%pseudo_salt_may_reinit) CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index c20c44e443..3166667849 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -42,7 +42,7 @@ module USER_tracer_example use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -152,12 +152,11 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) - ! Register the tracer for the restart file. - call register_restart_field(tr_ptr, CS%tr_desc(m), .true., restart_CS) - ! Register the tracer for horizontal advection & diffusion. + ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=name, longname=longname, units="kg kg-1", & - registry_diags=.true., flux_units=flux_units) + registry_diags=.true., flux_units=flux_units, & + restart_CS=restart_CS) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will From f8d77887c001510b95a089bb2b87b407291d6327 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jan 2018 09:49:50 -0500 Subject: [PATCH 122/170] Removed white space from 2 blank lines --- src/framework/MOM_restart.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index dd01fec9d4..21deb62a45 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -387,7 +387,7 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units type(vardesc) :: vd character(len=8) :: hgrid - + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_3d: Module must be initialized before "//& "it is used to register "//trim(name)) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 2eefddd3c8..6f4b02d080 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -165,7 +165,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit !! restarts if this argument is present logical, optional, intent(in) :: mandatory !< If true, this tracer must be read !! from a restart file. - + logical :: mand type(tracer_type), pointer :: Tr=>NULL() character(len=256) :: mesg ! Message for error messages. From 68ad7f2c6c2acffa3f6be83dd32125b1bb0a8920 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jan 2018 10:08:06 -0500 Subject: [PATCH 123/170] Removed 1 blank line with whitespace --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 463c5fca57..ce32e25b49 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -472,7 +472,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & Sal, & ! The salinity after a timestep of mixing, in psu. u_test, v_test, T_test, S_test - real, dimension(nzc+1) :: & N2, & ! The squared buoyancy frequency at an interface, in s-2. dz_Int, & ! The extent of a finite-volume space surrounding an interface, From 44d73d2102139d1593ab899dbecd2188f80a2a1e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jan 2018 15:28:05 -0500 Subject: [PATCH 124/170] Fix uninitialized variables in lookup_seg_field() - Somehow the gnu compiler started complaining about an uninitialized variable that it wasn't complaining about before. It was uninitialized and has now been fixed. - Also added some doxygen. --- src/core/MOM_open_boundary.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 945fc5ad0e..73a98040aa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1715,23 +1715,22 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) end subroutine set_tracer_data +!> Needs documentation function lookup_seg_field(OBC_seg,field) - type(OBC_segment_type), pointer :: OBC_seg - character(len=32), intent(in) :: field ! The field name + type(OBC_segment_type), pointer :: OBC_seg !< OBC segment + character(len=32), intent(in) :: field !< The field name integer :: lookup_seg_field - - integer :: n,m + ! Local variables + integer :: n lookup_seg_field=-1 do n=1,OBC_seg%num_fields - if (trim(field) == OBC_seg%field(m)%name) then + if (trim(field) == OBC_seg%field(n)%name) then lookup_seg_field=n return endif enddo - return - end function lookup_seg_field From 34fcacb93a9ea7a6869ab6d2d4ecc481e7be21a3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jan 2018 15:30:39 -0500 Subject: [PATCH 125/170] Fix incomplete setup of OBC segment structure - The loop parsing the configuration of each OBC segment was exiting early. This left the segments incomplete on PEs that are not intersected by the segment. We need the segment to be completely parsed in order for global behavior to be consistent, even if not all data is allocated on all PEs. --- src/core/MOM_open_boundary.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 73a98040aa..5e1ecf009b 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -718,10 +718,11 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) "String '"//trim(action_str(a_loop))//"' not understood.") endif - if (I_obc<=G%HI%IsdB .or. I_obc>=G%HI%IedB) return ! Boundary is not on tile - if (Je_obc<=G%HI%JsdB .or. Js_obc>=G%HI%JedB) return ! Segment is not on tile enddo ! a_loop + if (I_obc<=G%HI%IsdB .or. I_obc>=G%HI%IedB) return ! Boundary is not on tile + if (Je_obc<=G%HI%JsdB .or. Js_obc>=G%HI%JedB) return ! Segment is not on tile + OBC%segment(l_seg)%on_pe = .true. OBC%segment(l_seg)%is_E_or_W = .true. @@ -820,10 +821,11 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) "String '"//trim(action_str(a_loop))//"' not understood.") endif - if (J_obc<=G%HI%JsdB .or. J_obc>=G%HI%JedB) return ! Boundary is not on tile - if (Ie_obc<=G%HI%IsdB .or. Is_obc>=G%HI%IedB) return ! Segment is not on tile enddo ! a_loop + if (J_obc<=G%HI%JsdB .or. J_obc>=G%HI%JedB) return ! Boundary is not on tile + if (Ie_obc<=G%HI%IsdB .or. Is_obc>=G%HI%IedB) return ! Segment is not on tile + OBC%segment(l_seg)%on_pe = .true. OBC%segment(l_seg)%is_N_or_S = .true. From 2bcc16863357efc4104a8e3fc5541b8cebe3b30f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jan 2018 15:40:19 -0500 Subject: [PATCH 126/170] Fixed restarts to work for all PE layouts - Restarts with OBCs were only working when all PEs had an OBC segment intersect each PE. --- src/core/MOM_open_boundary.F90 | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5e1ecf009b..e5bc5a037d 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -168,6 +168,7 @@ module MOM_open_boundary !! in the global domain use specified BCs. logical :: specified_v_BCs_exist_globally = .false. !< True if any meridional velocity points !! in the global domain use specified BCs. + logical :: radiation_BCs_exist_globally = .false. !< True if radiations BCs are in use anywhere. logical :: user_BCs_set_globally = .false. !< True if any OBC_USER_CONFIG is set !! for input from user directory. logical :: update_OBC = .false. !< Is OBC data time-dependent @@ -686,6 +687,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) OBC%segment(l_seg)%radiation = .true. OBC%segment(l_seg)%open = .true. OBC%open_u_BCs_exist_globally = .true. + OBC%radiation_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'OBLIQUE') then OBC%segment(l_seg)%oblique = .true. OBC%segment(l_seg)%open = .true. @@ -705,6 +707,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) OBC%segment(l_seg)%radiation = .true. OBC%Flather_u_BCs_exist_globally = .true. OBC%open_u_BCs_exist_globally = .true. + OBC%radiation_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE') then OBC%segment(l_seg)%specified = .true. OBC%specified_u_BCs_exist_globally = .true. ! This avoids deallocation @@ -789,6 +792,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) OBC%segment(l_seg)%radiation = .true. OBC%segment(l_seg)%open = .true. OBC%open_v_BCs_exist_globally = .true. + OBC%radiation_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'OBLIQUE') then OBC%segment(l_seg)%oblique = .true. OBC%segment(l_seg)%open = .true. @@ -808,6 +812,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) OBC%segment(l_seg)%Flather = .true. OBC%Flather_v_BCs_exist_globally = .true. OBC%open_v_BCs_exist_globally = .true. + OBC%radiation_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE') then OBC%segment(l_seg)%specified = .true. OBC%specified_v_BCs_exist_globally = .true. ! This avoids deallocation @@ -2624,14 +2629,14 @@ subroutine flood_fill2(G, color, cin, cout, cland) end subroutine flood_fill2 +!> Register OBC segment data for restarts subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) - type(hor_index_type), intent(in) :: HI - type(verticalGrid_type), pointer, intent(in) :: GV + type(hor_index_type), intent(in) :: HI !< Horizontal indices + type(verticalGrid_type), pointer, intent(in) :: GV !< Container for vertical grid information type(ocean_OBC_type), pointer, intent(inout) :: OBC_CS !< OBC data structure - type(MOM_restart_CS), pointer, intent(inout) :: restart_CSp + type(MOM_restart_CS), pointer, intent(inout) :: restart_CSp !< Restart structure + ! Local variables type(vardesc) :: vd - logical :: rx_normal_associated - integer :: n if (.not. associated(OBC_CS)) & call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& @@ -2641,14 +2646,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& "arrays were previously allocated") - - rx_normal_associated = .false. - - do n=1,OBC_CS%number_of_segments - if (associated(OBC_CS%segment(n)%rx_normal)) rx_normal_associated = .true. - enddo - - if (rx_normal_associated) then + if (OBC_CS%radiation_BCs_exist_globally) then allocate(OBC_CS%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) OBC_CS%rx_normal(:,:,:) = 0.0 vd = var_desc("rx_normal","m s-1", "Normal Phase Speed for EW OBCs",'u','L') From 6e3f8a4abe1fccc0cd1442826914afbf5e5a13ee Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jan 2018 15:45:18 -0500 Subject: [PATCH 127/170] Added comment flagging work around code --- src/core/MOM_open_boundary.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index e5bc5a037d..493d79f1c8 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2646,6 +2646,10 @@ subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& "arrays were previously allocated") + ! *** This is a temporary work around for restarts with OBC segments. + ! This implementation uses 3D arrays solely for restarts. We need + ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using + ! so much memory and disk space. *** if (OBC_CS%radiation_BCs_exist_globally) then allocate(OBC_CS%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) OBC_CS%rx_normal(:,:,:) = 0.0 From 74aca31a590ee284dabb372568edf4081815f26d Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 19 Jan 2018 17:17:47 -0500 Subject: [PATCH 128/170] Enhancement and Clean up --- src/framework/MOM_io.F90 | 21 ----- src/framework/MOM_restart.F90 | 158 ++++++++++++++++------------------ 2 files changed, 76 insertions(+), 103 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index ec0952c714..89c8e68109 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -953,27 +953,6 @@ subroutine MOM_io_init(param_file) end subroutine MOM_io_init -!The following won't compile, otherwise I could have used it to write the checksum attribute for each field -!MOM_io.F90(966): error #6292: The parent type of this field is use associated -!with the PRIVATE fields attribute. [ID] -! call mpp_write_meta( unit, field%id, trim(meta_name), cval=meta_char ) -!-----------------------------------^ -! -!subroutine write_meta(unit, field, meta_name, meta_value) -! integer, intent(out) :: unit !< unit id of an open file or -1 on a -! !! nonwriting PE with single file output -! type(fieldtype), intent(in) :: field !< fieldtype for the variable that meta data should be added -! character(len=*), intent(in) :: meta_name !< name of meta data to be added -! integer(kind=8), intent(in) :: meta_value !< value of meta data corresponding to meta_name -! -! character(len=64) :: meta_char -! -! write (meta_char,'(Z16)') meta_value -! call mpp_write_meta( unit, field%id, trim(meta_name), cval=meta_char ) -! -!end subroutine write_meta - - !> \namespace mom_io !! diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index e5c91021d7..6eb05b4eee 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -59,7 +59,6 @@ module MOM_restart use MOM_verticalGrid, only : verticalGrid_type use mpp_mod, only: mpp_chksum use mpp_io_mod, only: mpp_attribute_exist, mpp_get_atts -use mpp_domains_mod, only: mpp_get_domain_shift implicit none ; private @@ -740,9 +739,8 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) real :: restart_time character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs integer :: length - integer(kind=8) :: check_val(CS%max_fields,1), checksum - integer :: iadd,jadd,ishift, jshift, pos - integer :: isL,ieL,jsL,jeL,sizes(7) + integer(kind=8) :: check_val(CS%max_fields,1) + integer :: isL,ieL,jsL,jeL if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") @@ -844,42 +842,18 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) call modify_vardesc(vars(1), t_grid='s', caller="save_restart") !Prepare the checksum of the restart fields to be written to restart files + call get_MOM_compute_domain(G,isL,ieL,jsL,jeL) do m=start_var,next_var-1 - call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, caller="save_restart") - select case (hor_grid) - case ('q') ; pos = CORNER - case ('h') ; pos = CENTER - case ('u') ; pos = EAST_FACE - case ('v') ; pos = NORTH_FACE - case ('Bu') ; pos = CORNER - case ('T') ; pos = CENTER - case ('Cu') ; pos = EAST_FACE - case ('Cv') ; pos = NORTH_FACE - case ('1') ; pos = 0 - case default ; pos = 0 - end select - call mpp_get_domain_shift(G%Domain%mpp_domain, ishift, jshift, pos) - iadd = G%iec-G%isc ! Size of the i-dimension on this processor (-1 as it is an increment) - jadd = G%jec-G%jsc ! Size of the j-dimension on this processor - if(G%iec == G%ieg) iadd = iadd + ishift - if(G%jec == G%jeg) jadd = jadd + jshift - isL=G%isc-G%isd+1 - ieL=G%iec-G%isd+1 - jsL=G%jsc-G%jsd+1 - jeL=G%jec-G%jsd+1 -! call get_file_atts(CS%restart_field(m)%vars,siz=sizes) -! call get_MOM_compute_domain(G,sizes,pos,isL,ieL,jsL,jeL) - if (ASSOCIATED(CS%var_ptr3d(m)%p)) then - check_val(m,1) = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) elseif (ASSOCIATED(CS%var_ptr2d(m)%p)) then - check_val(m,1) = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) elseif (ASSOCIATED(CS%var_ptr4d(m)%p)) then - check_val(m,1) = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) elseif (ASSOCIATED(CS%var_ptr1d(m)%p)) then - check_val(m,1) = mpp_chksum(CS%var_ptr1d(m)%p) + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr1d(m)%p) elseif (ASSOCIATED(CS%var_ptr0d(m)%p)) then - check_val(m,1) = mpp_chksum(CS%var_ptr0d(m)%p) + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr0d(m)%p) endif enddo @@ -969,7 +943,7 @@ subroutine restore_state(filename, directory, day, G, CS) logical :: check_exist, is_there_a_checksum integer(kind=8),dimension(1) :: checksum_file integer(kind=8) :: checksum_data - integer :: iadd,jadd,ishift, jshift + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "restore_state: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -1055,15 +1029,7 @@ subroutine restore_state(filename, directory, day, G, CS) case default ; pos = 0 end select - call mpp_get_domain_shift(G%Domain%mpp_domain, ishift, jshift, pos) - iadd = G%iec-G%isc ! Size of the i-dimension on this processor (-1 as it is an increment) - jadd = G%jec-G%jsc ! Size of the j-dimension on this processor - if(G%iec == G%ieg) iadd = iadd + ishift - if(G%jec == G%jeg) jadd = jadd + jshift - isL=G%isc-G%isd+1 - ieL=G%iec-G%isd+1 - jsL=G%jsc-G%jsd+1 - jeL=G%jec-G%jsd+1 + call get_MOM_compute_domain(G,isL,ieL,jsL,jeL) do i=1, nvar call get_file_atts(fields(i),name=varname) @@ -1190,7 +1156,6 @@ subroutine restore_state(filename, directory, day, G, CS) endif endif - if(is_root_pe()) write(*,'(a,Z16,a,Z16)') "Checksums of input field "// trim(varname)//" ",checksum_data," ", checksum_file(1) if(is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& " does not match value ", checksum_file(1), & @@ -1200,12 +1165,10 @@ subroutine restore_state(filename, directory, day, G, CS) CS%restart_field(m)%initialized = .true. exit ! Start search for next restart variable. - - endif - - enddo + endif + enddo if (i>nvar) missing_fields = missing_fields+1 - enddo + enddo deallocate(fields) if (missing_fields == 0) exit @@ -1550,40 +1513,71 @@ subroutine restart_error(CS) endif end subroutine restart_error -subroutine get_MOM_compute_domain(G,sizes,pos,isL,ieL,jsL,jeL) +subroutine get_MOM_compute_domain(G,isL,ieL,jsL,jeL) +! use mpp_domains_mod, only: mpp_get_domain_shift type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - integer , intent(in) :: sizes(:),pos integer , intent(out):: isL,ieL,jsL,jeL - integer :: is0,js0 - ! NOTE: The index ranges f var_ptrs always start with 1, so with - ! symmetric memory the staggering is swapped from NE to SW! - is0 = 1-G%isd - if ((pos == EAST_FACE) .or. (pos == CORNER)) is0 = 1-G%IsdB - if (sizes(1) == G%iec-G%isc+1) then - isL = G%isc+is0 ; ieL = G%iec+is0 - elseif (sizes(1) == G%IecB-G%IscB+1) then - isL = G%IscB+is0 ; ieL = G%IecB+is0 - elseif (((pos == EAST_FACE) .or. (pos == CORNER)) .and. & - (G%IscB == G%isc) .and. (sizes(1) == G%iec-G%isc+2)) then - ! This is reading a symmetric file in a non-symmetric model. - isL = G%isc-1+is0 ; ieL = G%iec+is0 - else - call MOM_error(WARNING, "MOM_restart restore_state, i-size ") - endif - - js0 = 1-G%jsd - if ((pos == NORTH_FACE) .or. (pos == CORNER)) js0 = 1-G%JsdB - if (sizes(2) == G%jec-G%jsc+1) then - jsL = G%jsc+js0 ; jeL = G%jec+js0 - elseif (sizes(2) == G%jecB-G%jscB+1) then - jsL = G%jscB+js0 ; jeL = G%jecB+js0 - elseif (((pos == NORTH_FACE) .or. (pos == CORNER)) .and. & - (G%JscB == G%jsc) .and. (sizes(2) == G%jec-G%jsc+2)) then - ! This is reading a symmetric file in a non-symmetric model. - jsL = G%jsc-1+js0 ; jeL = G%jec+js0 - else - call MOM_error(WARNING, "MOM_restart restore_state, wrong j-size ") - endif +! integer , intent(in) :: sizes(:),pos +! integer :: is0,js0 +! integer :: iadd,jadd,ishift, jshift, pos,sizes(7) + + !Simplistic way + isL=G%isc-G%isd+1 + ieL=G%iec-G%isd+1 + jsL=G%jsc-G%jsd+1 + jeL=G%jec-G%jsd+1 + + !Zhi's way +! call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, caller="save_restart") +! select case (hor_grid) +! case ('q') ; pos = CORNER +! case ('h') ; pos = CENTER +! case ('u') ; pos = EAST_FACE +! case ('v') ; pos = NORTH_FACE +! case ('Bu') ; pos = CORNER +! case ('T') ; pos = CENTER +! case ('Cu') ; pos = EAST_FACE +! case ('Cv') ; pos = NORTH_FACE +! case ('1') ; pos = 0 +! case default ; pos = 0 +! end select +! call mpp_get_domain_shift(G%Domain%mpp_domain, ishift, jshift, pos) +! iadd = G%iec-G%isc ! Size of the i-dimension on this processor (-1 as it is an increment) +! jadd = G%jec-G%jsc ! Size of the j-dimension on this processor +! if(G%iec == G%ieg) iadd = iadd + ishift +! if(G%jec == G%jeg) jadd = jadd + jshift +! ? + + !Bob's way + ! NOTE: The index ranges f var_ptrs always start with 1, so with + ! symmetric memory the staggering is swapped from NE to SW! +! is0 = 1-G%isd +! if ((pos == EAST_FACE) .or. (pos == CORNER)) is0 = 1-G%IsdB +! if (sizes(1) == G%iec-G%isc+1) then +! isL = G%isc+is0 ; ieL = G%iec+is0 +! elseif (sizes(1) == G%IecB-G%IscB+1) then +! isL = G%IscB+is0 ; ieL = G%IecB+is0 +! elseif (((pos == EAST_FACE) .or. (pos == CORNER)) .and. & +! (G%IscB == G%isc) .and. (sizes(1) == G%iec-G%isc+2)) then +! ! This is reading a symmetric file in a non-symmetric model. +! isL = G%isc-1+is0 ; ieL = G%iec+is0 +! else +! call MOM_error(WARNING, "MOM_restart restore_state, i-size ") +! endif +! +! js0 = 1-G%jsd +! if ((pos == NORTH_FACE) .or. (pos == CORNER)) js0 = 1-G%JsdB +! if (sizes(2) == G%jec-G%jsc+1) then +! jsL = G%jsc+js0 ; jeL = G%jec+js0 +! elseif (sizes(2) == G%jecB-G%jscB+1) then +! jsL = G%jscB+js0 ; jeL = G%jecB+js0 +! elseif (((pos == NORTH_FACE) .or. (pos == CORNER)) .and. & +! (G%JscB == G%jsc) .and. (sizes(2) == G%jec-G%jsc+2)) then +! ! This is reading a symmetric file in a non-symmetric model. +! jsL = G%jsc-1+js0 ; jeL = G%jec+js0 +! else +! call MOM_error(WARNING, "MOM_restart restore_state, wrong j-size ") +! endif end subroutine get_MOM_compute_domain From ea6651f98a365bc3c571f80fd2d0e1b3fb51bacf Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 19 Jan 2018 17:52:25 -0500 Subject: [PATCH 129/170] bug fix --- src/tracer/MOM_generic_tracer.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index e14c7074a4..7bf85e5ecb 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -194,13 +194,13 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? tr_ptr => tr_field(:,:,:,1) ! Register prognastic tracer for horizontal advection, diffusion, and restarts. - if (g_tracer_is_prog(g_tracer)) & + if (g_tracer_is_prog(g_tracer)) then call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=g_tracer_name, longname=longname, units=units, & registry_diags=.false., & !### CHANGE TO TRUE? restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) else - call register_restart_field(tr_ptr, name=g_tracer_name, .not.CS%tracers_may_reinit, & + call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & restart_CS, longname=longname, units=units) endif From 9f494cb009f3aaf73821256a31dd03bd1591d4e5 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 19 Jan 2018 17:56:26 -0500 Subject: [PATCH 130/170] Fixing a bug that causes compile error --- src/tracer/MOM_generic_tracer.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index e14c7074a4..7bf85e5ecb 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -194,13 +194,13 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? tr_ptr => tr_field(:,:,:,1) ! Register prognastic tracer for horizontal advection, diffusion, and restarts. - if (g_tracer_is_prog(g_tracer)) & + if (g_tracer_is_prog(g_tracer)) then call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=g_tracer_name, longname=longname, units=units, & registry_diags=.false., & !### CHANGE TO TRUE? restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) else - call register_restart_field(tr_ptr, name=g_tracer_name, .not.CS%tracers_may_reinit, & + call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & restart_CS, longname=longname, units=units) endif From f4ba3e7815567aff47d7659362bbdc59cceb8f19 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jan 2018 19:09:03 -0500 Subject: [PATCH 131/170] Handle tiny and huge values in left_real Modified real_string and left_real to handle the output of nonzero values smaller in magnitude than 1e-100 or larger than 1e100. All answers are bitwise identical. --- src/framework/MOM_document.F90 | 11 ++++++++--- src/framework/MOM_string_functions.F90 | 11 ++++++++--- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index d2317178f8..a61c20cf5a 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -504,9 +504,14 @@ function real_string(val) elseif (val == 0.) then real_string = "0.0" else - write(real_string(1:32), '(ES23.14)') val - if (.not.testFormattedFloatIsReal(real_string,val)) then - write(real_string(1:32), '(ES23.15)') val + if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100)) then + write(real_string(1:32), '(ES24.14E3)') val + if (.not.testFormattedFloatIsReal(real_string,val)) & + write(real_string(1:32), '(ES24.15E3)') val + else + write(real_string(1:32), '(ES23.14)') val + if (.not.testFormattedFloatIsReal(real_string,val)) & + write(real_string(1:32), '(ES23.15)') val endif do ind = index(real_string,"0E") diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index cdc6fb8e12..c0f3ba2b28 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -124,9 +124,14 @@ function left_real(val) elseif (val == 0.) then left_real = "0.0" else - write(left_real(1:32), '(ES23.14)') val - if (.not.isFormattedFloatEqualTo(left_real,val)) then - write(left_real(1:32), '(ES23.15)') val + if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100)) then + write(left_real(1:32), '(ES24.14E3)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) & + write(left_real(1:32), '(ES24.15E3)') val + else + write(left_real(1:32), '(ES23.14)') val + if (.not.isFormattedFloatEqualTo(left_real,val)) & + write(left_real(1:32), '(ES23.15)') val endif do ind = index(left_real,"0E") From d213d034f988d8679582bc86ec39e57fea059dfc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jan 2018 23:18:12 -0500 Subject: [PATCH 132/170] +Removed MOM_CSp from diagnostic routines Eliminated references to the master MOM control structure from the diagnostic routines in MOM.F90. This involves a number of internal interface changes, but all answer are bitwise identical. --- src/core/MOM.F90 | 110 ++++++++++++++++++++++++++++------------------- 1 file changed, 65 insertions(+), 45 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7f588f987f..bc11ed67b5 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -174,6 +174,8 @@ module MOM integer :: id_sssabs = -1 integer :: id_T_vardec = -1, id_S_vardec = -1 + real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for variance decay through ALE + T_squared => NULL(), S_squared => NULL() ! heat and salt flux fields integer :: id_fraz = -1 @@ -315,9 +317,6 @@ module MOM vd_T, & !< vardesc array describing potential temperature vd_S !< vardesc array describing salinity - real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for variance decay through ALE - T_squared => NULL(), S_squared => NULL() - logical :: tendency_diagnostics = .false. type(MOM_diag_IDs) :: IDs @@ -989,8 +988,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) - call post_transport_diagnostics(G, GV, CS, CS%IDs, CS%diag, CS%t_dyn_rel_adv, h, & - h_pre_dyn, T_pre_dyn, S_pre_dyn) + call post_transport_diagnostics(G, GV, CS%uhtr, CS%vhtr, h, CS%IDs, CS%diag, CS%t_dyn_rel_adv, & + CS%diag_to_Z_CSp, h_pre_dyn, T_pre_dyn, S_pre_dyn) ! Rebuild the remap grids now that we've posted the fields which rely on thicknesses ! from before the dynamics calls call diag_update_remap_grids(CS%diag) @@ -1037,7 +1036,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm logical :: do_pass_kv_bbl_thick logical :: showCallTree - 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 ; nz = G%ke showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90") @@ -1101,13 +1100,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm ! call pass_vector(u, v, G%Domain) call do_group_pass(CS%pass_T_S_h, G%Domain) - ! update squared quantities - if (associated(CS%S_squared)) then ; do k=1,nz ; do j=js,je ; do i=is,ie - CS%S_squared(i,j,k) = tv%S(i,j,k)**2 - enddo ; enddo ; enddo ; endif - if (associated(CS%T_squared)) then ; do k=1,nz ; do j=js,je ; do i=is,ie - CS%T_squared(i,j,k) = tv%T(i,j,k)**2 - enddo ; enddo ; enddo ; endif + call preAle_tracer_diags(G, CS%IDs, tv) if (CS%debug) then call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV) @@ -1141,7 +1134,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm ! happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) - call post_diags_TS_vardec(G, CS, CS%IDs, CS%diag, dtdia) + call post_diags_TS_vardec(G, CS%IDs, CS%diag, tv, dtdia) if (CS%debug) then call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2) @@ -2179,7 +2172,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call tracer_hor_diff_init(Time, G, param_file, diag, CS%tracer_diff_CSp, CS%neutral_diffusion_CSp) if (CS%use_ALE_algorithm) & - call register_diags_TS_vardec(Time, G%HI, GV, param_file, CS, CS%IDs, CS%diag) + call register_diags_TS_vardec(Time, G%HI, GV, param_file, CS%IDs, CS%tracer_Reg, CS%diag) call lock_tracer_registry(CS%tracer_Reg) call callTree_waypoint("tracer registry now locked (initialize_MOM)") @@ -2435,13 +2428,13 @@ end subroutine register_diags !> Initialize diagnostics for the variance decay of temp/salt !! across regridding/remapping -subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS, IDs, diag) - type(time_type), intent(in) :: Time !< current model time - type(hor_index_type), intent(in) :: HI !< horizontal index type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(param_file_type), intent(in) :: param_file !< parameter file - type(MOM_control_struct), pointer :: CS !< control structure for MOM +subroutine register_diags_TS_vardec(Time, HI, GV, param_file, IDs, tracer_Reg, diag) + type(time_type), intent(in) :: Time !< current model time + type(hor_index_type), intent(in) :: HI !< horizontal index type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(param_file_type), intent(in) :: param_file !< parameter file type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the MOM tracer registry type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output integer :: isd, ied, jsd, jed, nz @@ -2452,10 +2445,10 @@ subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS, IDs, diag) IDs%id_T_vardec = register_diag_field('ocean_model', 'T_vardec', diag%axesTL, Time, & 'ALE variance decay for temperature', 'degC2 s-1') if (IDs%id_T_vardec > 0) then - call safe_alloc_ptr(CS%T_squared,isd,ied,jsd,jed,nz) - CS%T_squared(:,:,:) = 0. + call safe_alloc_ptr(IDs%T_squared,isd,ied,jsd,jed,nz) + IDs%T_squared(:,:,:) = 0. - call register_tracer(CS%T_squared, CS%tracer_reg, param_file, HI, GV, & + call register_tracer(IDs%T_squared, tracer_reg, param_file, HI, GV, & name="T2", units="degC2", longname="Squared Potential Temperature", & registry_diags=.false.) endif @@ -2463,10 +2456,10 @@ subroutine register_diags_TS_vardec(Time, HI, GV, param_file, CS, IDs, diag) IDs%id_S_vardec = register_diag_field('ocean_model', 'S_vardec', diag%axesTL, Time, & 'ALE variance decay for salinity', 'psu2 s-1') if (IDs%id_S_vardec > 0) then - call safe_alloc_ptr(CS%S_squared,isd,ied,jsd,jed,nz) - CS%S_squared(:,:,:) = 0. + call safe_alloc_ptr(IDs%S_squared,isd,ied,jsd,jed,nz) + IDs%S_squared(:,:,:) = 0. - call register_tracer(CS%S_squared, CS%tracer_reg, param_file, HI, GV, & + call register_tracer(IDs%S_squared, tracer_reg, param_file, HI, GV, & name="S2", units="psu2", longname="Squared Salinity", & registry_diags=.false.) endif @@ -2505,16 +2498,23 @@ end subroutine MOM_timing_init !> This routine posts diagnostics of the transports, including the subgridscale !! contributions. -subroutine post_transport_diagnostics(G, GV, CS, IDs, diag, dt_trans, h, & - h_pre_dyn, T_pre_dyn, S_pre_dyn) +subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag, dt_trans, & + diag_to_Z_CSp, h_pre_dyn, T_pre_dyn, S_pre_dyn) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(MOM_control_struct), intent(in) :: CS !< control structure - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. - type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real , intent(in) :: dt_trans !< total time step associated with the transports, in s. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: uhtr !< Accumulated zonal thickness fluxes used + !! to advect tracers (m3 or kg) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: vhtr !< Accumulated meridional thickness fluxes + !! used to advect tracers (m3 or kg) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< The updated layer thicknesses, in H + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + real, intent(in) :: dt_trans !< total time step associated with the transports, in s. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A control structure for remapping + !! the transports to depth space real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h_pre_dyn !< The thickness before the transports, in H. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -2531,8 +2531,7 @@ subroutine post_transport_diagnostics(G, GV, CS, IDs, diag, dt_trans, h, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke call cpu_clock_begin(id_clock_Z_diag) - call calculate_Z_transport(CS%uhtr, CS%vhtr, h, dt_trans, G, GV, & - CS%diag_to_Z_CSp) + call calculate_Z_transport(uhtr, vhtr, h, dt_trans, G, GV, diag_to_Z_CSp) call cpu_clock_end(id_clock_Z_diag) ! Post mass transports, including SGS @@ -2544,34 +2543,34 @@ subroutine post_transport_diagnostics(G, GV, CS, IDs, diag, dt_trans, h, & if (IDs%id_umo_2d > 0) then umo2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do I=is-1,ie - umo2d(I,j) = umo2d(I,j) + CS%uhtr(I,j,k) * H_to_kg_m2_dt + umo2d(I,j) = umo2d(I,j) + uhtr(I,j,k) * H_to_kg_m2_dt enddo ; enddo ; enddo call post_data(IDs%id_umo_2d, umo2d, diag) endif if (IDs%id_umo > 0) then ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below do k=1,nz ; do j=js,je ; do I=is-1,ie - umo(I,j,k) = CS%uhtr(I,j,k) * H_to_kg_m2_dt + umo(I,j,k) = uhtr(I,j,k) * H_to_kg_m2_dt enddo ; enddo ; enddo call post_data(IDs%id_umo, umo, diag, alt_h = h_pre_dyn) endif if (IDs%id_vmo_2d > 0) then vmo2d(:,:) = 0.0 do k=1,nz ; do J=js-1,je ; do i=is,ie - vmo2d(i,J) = vmo2d(i,J) + CS%vhtr(i,J,k) * H_to_kg_m2_dt + vmo2d(i,J) = vmo2d(i,J) + vhtr(i,J,k) * H_to_kg_m2_dt enddo ; enddo ; enddo call post_data(IDs%id_vmo_2d, vmo2d, diag) endif if (IDs%id_vmo > 0) then ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below do k=1,nz ; do J=js-1,je ; do i=is,ie - vmo(i,J,k) = CS%vhtr(i,J,k) * H_to_kg_m2_dt + vmo(i,J,k) = vhtr(i,J,k) * H_to_kg_m2_dt enddo ; enddo ; enddo call post_data(IDs%id_vmo, vmo, diag, alt_h = h_pre_dyn) endif - if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, CS%uhtr, diag, alt_h = h_pre_dyn) - if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, CS%vhtr, diag, alt_h = h_pre_dyn) + if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h = h_pre_dyn) + if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h = h_pre_dyn) end subroutine post_transport_diagnostics @@ -2635,12 +2634,33 @@ subroutine post_TS_diagnostics(IDs, G, GV, tv, diag, dt) end subroutine post_TS_diagnostics + +!> Calculate tracer diagnostic terms before the ALE update +subroutine preAle_tracer_diags(G, IDs, tv) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + ! Update squared quantities + if (associated(IDs%S_squared)) then ; do k=1,nz ; do j=js,je ; do i=is,ie + IDs%S_squared(i,j,k) = tv%S(i,j,k)**2 + enddo ; enddo ; enddo ; endif + if (associated(IDs%T_squared)) then ; do k=1,nz ; do j=js,je ; do i=is,ie + IDs%T_squared(i,j,k) = tv%T(i,j,k)**2 + enddo ; enddo ; enddo ; endif + +end subroutine preAle_tracer_diags + + !> Calculate and post variance decay diagnostics for temp/salt -subroutine post_diags_TS_vardec(G, CS, IDs, diag, dt) +subroutine post_diags_TS_vardec(G, IDs, diag, tv, dt) type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(MOM_control_struct), intent(in) :: CS !< control structure type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, intent(in) :: dt !< total time step real :: work(SZI_(G),SZJ_(G),SZK_(G)) @@ -2652,14 +2672,14 @@ subroutine post_diags_TS_vardec(G, CS, IDs, diag, dt) if (IDs%id_T_vardec > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work(i,j,k) = (CS%T_squared(i,j,k) - CS%tv%T(i,j,k)**2) * Idt + work(i,j,k) = (IDs%T_squared(i,j,k) - tv%T(i,j,k)**2) * Idt enddo ; enddo ; enddo call post_data(IDs%id_T_vardec, work, diag) endif if (IDs%id_S_vardec > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work(i,j,k) = (CS%S_squared(i,j,k) - CS%tv%S(i,j,k)**2) * Idt + work(i,j,k) = (IDs%S_squared(i,j,k) - tv%S(i,j,k)**2) * Idt enddo ; enddo ; enddo call post_data(IDs%id_S_vardec, work, diag) endif From e2704a0b08a129660c2ec4ec2ffdd252cf380492 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 22 Jan 2018 12:03:06 -0500 Subject: [PATCH 133/170] Fixing the white space errors caught by travis --- src/framework/MOM_io.F90 | 2 +- src/framework/MOM_restart.F90 | 5 ----- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 63f3bfe581..d708fcdf27 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -325,7 +325,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if(present(checksums)) then call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack, checksum=checksums(k,:)) - else + else call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack) endif diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 2bf24b1ce8..565816bdba 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1126,7 +1126,6 @@ subroutine restore_state(filename, directory, day, G, CS) end select call get_MOM_compute_domain(G,isL,ieL,jsL,jeL) - do i=1, nvar call get_file_atts(fields(i),name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then @@ -1139,7 +1138,6 @@ subroutine restore_state(filename, directory, day, G, CS) is_there_a_checksum = .true. endif if (.NOT. checksum_required ) is_there_a_checksum = .false. ! Do not need to do data checksumming. - if (ASSOCIATED(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. @@ -1622,7 +1620,6 @@ subroutine get_MOM_compute_domain(G,isL,ieL,jsL,jeL) ieL=G%iec-G%isd+1 jsL=G%jsc-G%jsd+1 jeL=G%jec-G%jsd+1 - !Zhi's way ! call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, caller="save_restart") ! select case (hor_grid) @@ -1642,8 +1639,6 @@ subroutine get_MOM_compute_domain(G,isL,ieL,jsL,jeL) ! jadd = G%jec-G%jsc ! Size of the j-dimension on this processor ! if(G%iec == G%ieg) iadd = iadd + ishift ! if(G%jec == G%jeg) jadd = jadd + jshift -! ? - !Bob's way ! NOTE: The index ranges f var_ptrs always start with 1, so with ! symmetric memory the staggering is swapped from NE to SW! From 5e3697c8c3a929250eddbd3f230351035d4f01ea Mon Sep 17 00:00:00 2001 From: William Cooke Date: Mon, 22 Jan 2018 12:12:06 -0500 Subject: [PATCH 134/170] Adds output of Channel narrowing info to screen and dy_Cu and dx_Cv to geometry file. Still needs a FATAL if a channel is asked for but not set. --- .../MOM_shared_initialization.F90 | 59 ++++++++++++++----- 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index d2047ed965..e6453cce22 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -750,7 +750,7 @@ subroutine reset_face_lengths_list(G, param_file) ! model parameter values. character(len=120), pointer, dimension(:) :: lines => NULL() character(len=120) :: line - character(len=200) :: filename, chan_file, inputdir ! Strings for file/path + character(len=200) :: filename, chan_file, inputdir, mesg ! Strings for file/path character(len=40) :: mdl = "reset_face_lengths_list" ! This subroutine's name. real, pointer, dimension(:,:) :: & u_lat => NULL(), u_lon => NULL(), v_lat => NULL(), v_lon => NULL() @@ -908,9 +908,19 @@ subroutine reset_face_lengths_list(G, param_file) if (((lat >= u_lat(1,npt)) .and. (lat <= u_lat(2,npt))) .and. & (((lon >= u_lon(1,npt)) .and. (lon <= u_lon(2,npt))) .or. & ((lon_p >= u_lon(1,npt)) .and. (lon_p <= u_lon(2,npt))) .or. & - ((lon_m >= u_lon(1,npt)) .and. (lon_m <= u_lon(2,npt)))) ) & - - G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(u_width(npt), 0.0)) + ((lon_m >= u_lon(1,npt)) .and. (lon_m <= u_lon(2,npt)))) ) then + + G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(u_width(npt), 0.0)) + if ( G%mask2dCu(I,j) == 0.0 ) then + write(mesg,'(A,I4,A)') "read_face_lengths_list : G%mask2dCu is not defined for line ",npt, & + "Please update values in "//trim(filename) + call MOM_error(FATAL, mesg, all_print=.true.) + else + write(mesg,'(A54,2F8.2,A2,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& + u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") to ",G%dy_Cu(I,j),"m" + call MOM_error(WARNING, mesg, all_print=.true.) + endif + endif enddo G%areaCu(I,j) = G%dxCu(I,j)*G%dy_Cu(I,j) @@ -927,8 +937,18 @@ subroutine reset_face_lengths_list(G, param_file) if (((lat >= v_lat(1,npt)) .and. (lat <= v_lat(2,npt))) .and. & (((lon >= v_lon(1,npt)) .and. (lon <= v_lon(2,npt))) .or. & ((lon_p >= v_lon(1,npt)) .and. (lon_p <= v_lon(2,npt))) .or. & - ((lon_m >= v_lon(1,npt)) .and. (lon_m <= v_lon(2,npt)))) ) & + ((lon_m >= v_lon(1,npt)) .and. (lon_m <= v_lon(2,npt)))) ) then G%dx_Cv(i,J) = G%mask2dCv(i,J) * min(G%dxCv(i,J), max(v_width(npt), 0.0)) + if ( G%mask2dCv(I,j) == 0.0 ) then + write(mesg,'(A,I4,A)') "read_face_lengths_list : G%mask2dCv is not defined for line ",npt, & + "Please update values in "//trim(filename) + call MOM_error(FATAL, mesg, all_print=.true.) + else + write(mesg,'(A54,2F8.2,A2,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& + v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") to ",G%dx_Cv(I,j),"m" + call MOM_error(WARNING, mesg, all_print=.true.) + endif + endif enddo G%areaCv(i,J) = G%dyCv(i,J)*G%dx_Cv(i,J) @@ -1079,7 +1099,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) ! (in) directory - The directory into which to place the file. character(len=240) :: filepath character(len=40) :: mdl = "write_ocean_geometry_file" - integer, parameter :: nFlds=23 + integer, parameter :: nFlds=25 type(vardesc) :: vars(nFlds) type(fieldtype) :: fields(nFlds) integer :: unit @@ -1130,12 +1150,16 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) vars(18)= var_desc("dyCuo","m","Open meridional grid spacing at u points",'u','1','1') vars(19)= var_desc("wet", "nondim", "land or ocean?", 'h','1','1') - vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') - vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') - vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') - vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') + vars(20) = var_desc("dx_Cv","m","Modified Zonal grid spacing at v points",'v','1','1') + vars(21) = var_desc("dy_Cu","m","Modified Meridional grid spacing at u points",'u','1','1') + + vars(22) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') + vars(23) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') + vars(24) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') + vars(25) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') - nFlds_used = 19 ; if (G%bathymetry_at_vel) nFlds_used = 23 + + nFlds_used = 21 ; if (G%bathymetry_at_vel) nFlds_used = 25 if (present(geom_file)) then filepath = trim(directory) // trim(geom_file) @@ -1200,11 +1224,16 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) call write_field(unit, fields(18), G%Domain%mpp_domain, G%dy_Cu) call write_field(unit, fields(19), G%Domain%mpp_domain, G%mask2dT) + do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = G%dx_Cv(i,J) ; enddo ; enddo + call write_field(unit, fields(20), G%Domain%mpp_domain, out_v) + do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = G%dy_Cu(I,j) ; enddo ; enddo + call write_field(unit, fields(21), G%Domain%mpp_domain, out_u) + if (G%bathymetry_at_vel) then - call write_field(unit, fields(20), G%Domain%mpp_domain, G%Dblock_u) - call write_field(unit, fields(21), G%Domain%mpp_domain, G%Dopen_u) - call write_field(unit, fields(22), G%Domain%mpp_domain, G%Dblock_v) - call write_field(unit, fields(23), G%Domain%mpp_domain, G%Dopen_v) + call write_field(unit, fields(22), G%Domain%mpp_domain, G%Dblock_u) + call write_field(unit, fields(23), G%Domain%mpp_domain, G%Dopen_u) + call write_field(unit, fields(24), G%Domain%mpp_domain, G%Dblock_v) + call write_field(unit, fields(25), G%Domain%mpp_domain, G%Dopen_v) endif call close_file(unit) From 55203fd3243c0ed8f3a695b3e70a50be08f56879 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 22 Jan 2018 12:43:24 -0500 Subject: [PATCH 135/170] +Moved variance decay diags to tracer_registry Moved the temperature and salinity variance decay diagnostics into the tracer_registry, including the addition of the option to calculate the variance decay for other tracers. There are new interfaces and new diagnostics, some metadata on the variance decay diagnostics have changed for more generality, three subroutines were eliminated from MOM.F90, several elements were eliminated from the MOM_CS, and the available_diags files change in ALE experiments if any tracer packages are in use. All solutions and diagnostics are bitwise identical. --- src/core/MOM.F90 | 107 ++--------------------------- src/tracer/MOM_tracer_registry.F90 | 82 +++++++++++++++++++++- 2 files changed, 84 insertions(+), 105 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index bc11ed67b5..97adcc9aaa 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -122,6 +122,7 @@ module MOM use MOM_tracer_hor_diff, only : tracer_hor_diff_end, tracer_hor_diff_CS use MOM_tracer_registry, only : register_tracer, tracer_registry_init use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics +use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics use MOM_tracer_registry, only : add_tracer_diagnostics, tracer_registry_type use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_CS @@ -173,10 +174,6 @@ module MOM integer :: id_sstcon = -1 integer :: id_sssabs = -1 - integer :: id_T_vardec = -1, id_S_vardec = -1 - real, pointer, dimension(:,:,:) :: & !< diagnostic arrays for variance decay through ALE - T_squared => NULL(), S_squared => NULL() - ! heat and salt flux fields integer :: id_fraz = -1 integer :: id_salt_deficit = -1 @@ -1100,7 +1097,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm ! call pass_vector(u, v, G%Domain) call do_group_pass(CS%pass_T_S_h, G%Domain) - call preAle_tracer_diags(G, CS%IDs, tv) + call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) if (CS%debug) then call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV) @@ -1134,7 +1131,8 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm ! happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) - call post_diags_TS_vardec(G, CS%IDs, CS%diag, tv, dtdia) + !### Consider moving this up into the if ALE block. + call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) if (CS%debug) then call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2) @@ -2171,16 +2169,13 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call tracer_advect_init(Time, G, param_file, diag, CS%tracer_adv_CSp) call tracer_hor_diff_init(Time, G, param_file, diag, CS%tracer_diff_CSp, CS%neutral_diffusion_CSp) - if (CS%use_ALE_algorithm) & - call register_diags_TS_vardec(Time, G%HI, GV, param_file, CS%IDs, CS%tracer_Reg, CS%diag) - call lock_tracer_registry(CS%tracer_Reg) call callTree_waypoint("tracer registry now locked (initialize_MOM)") ! now register some diagnostics since the tracer registry is now locked call register_diags(Time, G, GV, CS%IDs, CS%diag, CS%tv%C_p, CS%missing, CS%tv) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & - CS%diag_to_Z_CSp) + CS%use_ALE_algorithm, CS%diag_to_Z_CSp) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, diag, CS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) endif @@ -2425,47 +2420,6 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) end subroutine register_diags - -!> Initialize diagnostics for the variance decay of temp/salt -!! across regridding/remapping -subroutine register_diags_TS_vardec(Time, HI, GV, param_file, IDs, tracer_Reg, diag) - type(time_type), intent(in) :: Time !< current model time - type(hor_index_type), intent(in) :: HI !< horizontal index type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(param_file_type), intent(in) :: param_file !< parameter file - type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. - type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the MOM tracer registry - type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - - integer :: isd, ied, jsd, jed, nz - - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke - - ! variancy decay through ALE operation - IDs%id_T_vardec = register_diag_field('ocean_model', 'T_vardec', diag%axesTL, Time, & - 'ALE variance decay for temperature', 'degC2 s-1') - if (IDs%id_T_vardec > 0) then - call safe_alloc_ptr(IDs%T_squared,isd,ied,jsd,jed,nz) - IDs%T_squared(:,:,:) = 0. - - call register_tracer(IDs%T_squared, tracer_reg, param_file, HI, GV, & - name="T2", units="degC2", longname="Squared Potential Temperature", & - registry_diags=.false.) - endif - - IDs%id_S_vardec = register_diag_field('ocean_model', 'S_vardec', diag%axesTL, Time, & - 'ALE variance decay for salinity', 'psu2 s-1') - if (IDs%id_S_vardec > 0) then - call safe_alloc_ptr(IDs%S_squared,isd,ied,jsd,jed,nz) - IDs%S_squared(:,:,:) = 0. - - call register_tracer(IDs%S_squared, tracer_reg, param_file, HI, GV, & - name="S2", units="psu2", longname="Squared Salinity", & - registry_diags=.false.) - endif - -end subroutine register_diags_TS_vardec - !> This subroutine sets up clock IDs for timing various subroutines. subroutine MOM_timing_init(CS) type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM. @@ -2634,57 +2588,6 @@ subroutine post_TS_diagnostics(IDs, G, GV, tv, diag, dt) end subroutine post_TS_diagnostics - -!> Calculate tracer diagnostic terms before the ALE update -subroutine preAle_tracer_diags(G, IDs, tv) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - ! Update squared quantities - if (associated(IDs%S_squared)) then ; do k=1,nz ; do j=js,je ; do i=is,ie - IDs%S_squared(i,j,k) = tv%S(i,j,k)**2 - enddo ; enddo ; enddo ; endif - if (associated(IDs%T_squared)) then ; do k=1,nz ; do j=js,je ; do i=is,ie - IDs%T_squared(i,j,k) = tv%T(i,j,k)**2 - enddo ; enddo ; enddo ; endif - -end subroutine preAle_tracer_diags - - -!> Calculate and post variance decay diagnostics for temp/salt -subroutine post_diags_TS_vardec(G, IDs, diag, tv, dt) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. - type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, intent(in) :: dt !< total time step - - real :: work(SZI_(G),SZJ_(G),SZK_(G)) - real :: Idt - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval - - if (IDs%id_T_vardec > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work(i,j,k) = (IDs%T_squared(i,j,k) - tv%T(i,j,k)**2) * Idt - enddo ; enddo ; enddo - call post_data(IDs%id_T_vardec, work, diag) - endif - - if (IDs%id_S_vardec > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work(i,j,k) = (IDs%S_squared(i,j,k) - tv%S(i,j,k)**2) * Idt - enddo ; enddo ; enddo - call post_data(IDs%id_S_vardec, work, diag) - endif -end subroutine post_diags_TS_vardec - !> This routine posts diagnostics of various integrated quantities. subroutine post_integrated_diagnostics(IDs, G, GV, diag, dt_int, tv, ssh, fluxes) type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 6f4b02d080..33594856bd 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -28,6 +28,7 @@ module MOM_tracer_registry public register_tracer public MOM_tracer_chksum, MOM_tracer_chkinv public register_tracer_diagnostics, post_tracer_diagnostics +public preALE_tracer_diagnostics, postALE_tracer_diagnostics public add_tracer_diagnostics, add_tracer_OBC_values public tracer_registry_init, lock_tracer_registry, tracer_registry_end @@ -83,6 +84,12 @@ module MOM_tracer_registry character(len=48) :: cmor_tendname = "" !< The CMOR variable name for tendencies of this !! tracer, required because CMOR does not follow any !! discernable pattern for these names. + integer :: ind_tr_squared = -1 + + !### THESE CAPABILITIES HAVE NOT YET BEEN IMPLEMENTED. + logical :: advect_tr = .true. !< If true, this tracer should be advected + logical :: hordiff_tr = .true. !< If true, this tracer should experience epineutral diffusion + logical :: remap_tr = .true. !< If true, this tracer should be vertically remapped integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. integer :: id_tr = -1 @@ -90,6 +97,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_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 + integer :: id_tr_vardec = -1 end type tracer_type !> Type to carry basic tracer information @@ -368,7 +376,7 @@ end subroutine add_tracer_diagnostics !> register_tracer_diagnostics does a set of register_diag_field calls for any previously !! registered in a tracer registry with a value of registry_diags set to .true. -subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) +subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_to_Z_CSp) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry @@ -376,6 +384,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) intent(in) :: h !< Layer thicknesses type(time_type), intent(in) :: Time !< current model time type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output + logical, intent(in) :: use_ALE !< If true active diagnostics that only + !! apply to ALE configurations type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure !! for diagnostics in depth space. @@ -395,7 +405,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic character(len=72) :: cmor_varname ! The temporary CMOR name for a diagnostic type(tracer_type), pointer :: Tr=>NULL() - integer :: i, j, k, is, ie, js, je, nz, m + integer :: i, j, k, is, ie, js, je, nz, m, m2, nTr_in integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -404,7 +414,9 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_diagnostics: "// & "register_tracer must be called before add_tracer_diagnostics") - do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then + nTr_in = Reg%ntr + + do m=1,nTr_in ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) ! call query_vardesc(Tr%vd, name, units=units, longname=longname, & ! cmor_field_name=cmorname, cmor_longname=cmor_longname, & @@ -544,10 +556,74 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, diag_to_Z_CSp) cmor_field_name=cmorname, cmor_standard_name=cmor_long_std(cmor_longname), & cmor_long_name=cmor_longname) endif + + if (use_ALE .and. (Reg%ntr 0) then + ! Set up a new tracer for this tracer squared + m2 = Reg%ntr+1 + Tr%ind_tr_squared = m2 + call safe_alloc_ptr(Reg%Tr(m2)%t,isd,ied,jsd,jed,nz) ; Reg%Tr(m2)%t(:,:,:) = 0.0 + Reg%Tr(m2)%name = trim(shortnm)//"2" + Reg%Tr(m2)%longname = "Squared "//trim(longname) + Reg%Tr(m2)%units = "("//trim(units)//")2" + Reg%Tr(m2)%registry_diags = .false. + Reg%Tr(m2)%ind_tr_squared = -1 + ! Augment the total number of tracers, including the squared tracers. + Reg%ntr = Reg%ntr + 1 + endif + endif + endif ; enddo end subroutine register_tracer_diagnostics +subroutine preALE_tracer_diagnostics(Reg, G, GV) + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + + integer :: i, j, k, is, ie, js, je, nz, m, m2 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do m=1,Reg%ntr ; if (Reg%Tr(m)%ind_tr_squared > 0) then + m2 = Reg%Tr(m)%ind_tr_squared + ! Update squared quantities + do k=1,nz ; do j=js,je ; do i=is,ie + Reg%Tr(m2)%T(i,j,k) = Reg%Tr(m)%T(i,j,k)**2 + enddo ; enddo ; enddo + endif ; enddo + +end subroutine preALE_tracer_diagnostics + +subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + real, intent(in) :: dt !< total time interval for these diagnostics + + real :: work(SZI_(G),SZJ_(G),SZK_(G)) + real :: Idt + integer :: i, j, k, is, ie, js, je, nz, m, m2 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + ! The "if" is to avoid NaNs if the diagnostic is called for a zero length interval + Idt = 0.0 ; if (dt /= 0.0) Idt = 1.0 / dt + + do m=1,Reg%ntr ; if (Reg%Tr(m)%id_tr_vardec > 0) then + m2 = Reg%Tr(m)%ind_tr_squared + if (m2 < 1) call MOM_error(FATAL, "Bad value of Tr%ind_tr_squared for "//trim(Reg%Tr(m)%name)) + ! Update squared quantities + do k=1,nz ; do j=js,je ; do i=is,ie + work(i,j,k) = (Reg%Tr(m2)%T(i,j,k) - Reg%Tr(m)%T(i,j,k)**2) * Idt + enddo ; enddo ; enddo + call post_data(Reg%Tr(m)%id_tr_vardec, work, diag) + endif ; enddo + +end subroutine postALE_tracer_diagnostics + !> post_tracer_diagnostics does post_data calls for any diagnostics that are !! being handled via the tracer registry. subroutine post_tracer_diagnostics(Reg, h, diag, G, GV, dt) From e691c0fdd6c34667299bd7e5bc0a2208606de1fd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jan 2018 09:41:00 -0500 Subject: [PATCH 136/170] Dynamically reformat tracer variance decay units Dynamically format the tracer variance decay units reported in output files and the available diagnostics files, depending on whether the units of the tracer concentration itself has an interior space. This reformatting could perhaps be made more elegant at a later date, but for now what is there is dimensionally correct and understandable. All answers are bitwise identical. --- src/tracer/MOM_tracer_registry.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 33594856bd..5def083740 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -394,12 +394,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ ! creating additional diagnostics. character(len=72) :: longname ! The long name of that tracer variable. character(len=72) :: flux_longname ! The tracer name in the long names of fluxes. - character(len=48) :: units ! The dimensions of the variable. + character(len=48) :: units ! The dimensions of the tracer. character(len=48) :: flux_units ! The units for fluxes, either ! [units] m3 s-1 or [units] kg s-1. character(len=48) :: conv_units ! The units for flux convergences, either ! [units] m2 s-1 or [units] kg s-1. - character(len=72) :: cmorname ! The CMOR name of that variable. + character(len=48) :: unit2 ! The dimensions of the tracer squared + character(len=72) :: cmorname ! The CMOR name of this tracer. character(len=120) :: cmor_longname ! The CMOR long name of that variable. character(len=120) :: var_lname ! A temporary longname for a diagnostic. character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic @@ -421,7 +422,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ ! call query_vardesc(Tr%vd, name, units=units, longname=longname, & ! cmor_field_name=cmorname, cmor_longname=cmor_longname, & ! caller="register_tracer_diagnostics") - name = Tr%name ; units=Tr%units ; longname = Tr%longname + name = Tr%name ; units=adjustl(Tr%units) ; longname = Tr%longname cmorname = Tr%cmor_name ; cmor_longname = Tr%cmor_longname shortnm = Tr%flux_nameroot flux_longname = Tr%flux_longname @@ -558,8 +559,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ endif if (use_ALE .and. (Reg%ntr 0) unit2 = "("//trim(units)//")2" Tr%id_tr_vardec = register_diag_field('ocean_model', trim(shortnm)//"_vardec", diag%axesTL, Time, & - "ALE variance decay for "//lowercase(longname), "("//trim(units)//")2 s-1") + "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1") if (Tr%id_tr_vardec > 0) then ! Set up a new tracer for this tracer squared m2 = Reg%ntr+1 @@ -567,7 +570,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ call safe_alloc_ptr(Reg%Tr(m2)%t,isd,ied,jsd,jed,nz) ; Reg%Tr(m2)%t(:,:,:) = 0.0 Reg%Tr(m2)%name = trim(shortnm)//"2" Reg%Tr(m2)%longname = "Squared "//trim(longname) - Reg%Tr(m2)%units = "("//trim(units)//")2" + Reg%Tr(m2)%units = unit2 Reg%Tr(m2)%registry_diags = .false. Reg%Tr(m2)%ind_tr_squared = -1 ! Augment the total number of tracers, including the squared tracers. From 57e4112c4a9fbc02f8cd81844799b6e62aab9734 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 23 Jan 2018 09:54:24 -0500 Subject: [PATCH 137/170] Fix non-allocated arrays in old sponges - Jenkins test of MESO_025_63L was failing at NCI https://accessdev.nci.org.au/jenkins/job/mom-ocean.org/job/MOM6_run/build=DEBUG,compiler=intel,experiment=ocean_only-MESO_025_63L,label=nah599,memory_type=dynamic/123/console due to use of non-allocated data in the read of sponge data. MESO is using the old style of sponges which we are not testing at GFDL. - Thanks to @nicjhan for keeping these complete tests going. --- src/initialization/MOM_state_initialization.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 2cf3a36cea..05cb0b4a1e 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1838,6 +1838,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, ! The first call to set_up_sponge_field is for the interface heights if in layered mode.! if (.not. use_ALE) then + allocate(eta(isd:ied,jsd:jed,nz+1)) call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) do j=js,je ; do i=is,ie @@ -1850,6 +1851,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, ! Set the inverse damping rates so that the model will know where to ! ! apply the sponges, along with the interface heights. ! call initialize_sponge(Idamp, eta, G, param_file, CSp) + deallocate(eta) else if (.not. new_sponges) then ! ALE mode call field_size(filename,eta_var,siz,no_domain=.true.) @@ -1876,6 +1878,8 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, h(i,j,k) = eta(i,j,k)-eta(i,j,k+1) enddo ; enddo; enddo call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp, h, nz_data) + deallocate(eta) + deallocate(h) else ! Initialize sponges without supplying sponge grid call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp) From 76feeb863843d6cc64151dc34b747a4e221cded1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 23 Jan 2018 15:14:56 -0500 Subject: [PATCH 138/170] Corrects experiment-specific topography/forcing documentation - @Hallberg-NOAA correctly gave @adcroft a hard time for allowing "TBD AJA" to enter into the parameter documentation and then propagate by way of example. This replaces those egregiously poor examples. --- src/initialization/MOM_state_initialization.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 2cf3a36cea..c3e2675f06 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -256,10 +256,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t\t densities. This is not yet implemented. \n"//& " \t circle_obcs - the circle_obcs test case is used. \n"//& " \t DOME2D - 2D version of DOME initialization. \n"//& - " \t adjustment2d - TBD AJA. \n"//& - " \t sloshing - TBD AJA. \n"//& - " \t seamount - TBD AJA. \n"//& - " \t dumbbell - TBD AJA. \n"//& + " \t adjustment2d - 2D lock exchange thickness ICs. \n"//& + " \t sloshing - sloshing gravity thickness ICs. \n"//& + " \t seamount - no motion test with seamount ICs. \n"//& + " \t dumbbell - sloshing channel ICs. \n"//& " \t soliton - Equatorial Rossby soliton. \n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t USER - call a user modified routine.", & @@ -329,10 +329,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t linear - linear in logical layer space. \n"//& " \t DOME2D - 2D DOME initialization. \n"//& " \t ISOMIP - ISOMIP initialization. \n"//& - " \t adjustment2d - TBD AJA. \n"//& - " \t sloshing - TBD AJA. \n"//& - " \t seamount - TBD AJA. \n"//& - " \t dumbbell. \n"//& + " \t adjustment2d - 2d lock exchange T/S ICs. \n"//& + " \t sloshing - sloshing mode T/S ICs. \n"//& + " \t seamount - no motion test with seamount ICs. \n"//& + " \t dumbbell - sloshing channel ICs. \n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t SCM_ideal_hurr - used in the SCM idealized hurricane test.\n"//& " \t SCM_CVmix_tests - used in the SCM CVmix tests.\n"//& From 51ab273109b1e7d1ee85267e58a08d096c7465a6 Mon Sep 17 00:00:00 2001 From: William Cooke Date: Tue, 23 Jan 2018 15:31:11 -0500 Subject: [PATCH 139/170] Reverted writing of dx_cv and dy_cu to ocean_geometry as they are there as dxCvo and dyCuo. Make available for output via register_status_field call. --- src/core/MOM.F90 | 9 +++++++ .../MOM_shared_initialization.F90 | 26 +++++++------------ 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 304da237c2..07f4786bf2 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3352,6 +3352,15 @@ subroutine write_static_fields(G, diag) 'Delta(y) at v points (meter)', 'm', interp_method='none') if (id > 0) call post_data(id, G%dyCv, diag, .true.) + id = register_static_field('ocean_model', 'dyCuo', diag%axesCu1, & + 'Open meridional grid spacing at u points (meter)', 'm', interp_method='none') + if (id > 0) call post_data(id, G%dy_Cu, diag, .true.) + + id = register_static_field('ocean_model', 'dxCvo', diag%axesCv1, & + 'Open zonal grid spacing at v points (meter)', 'm', interp_method='none') + if (id > 0) call post_data(id, G%dx_Cv, diag, .true.) + + ! This static diagnostic is from CF 1.8, and is the fraction of a cell ! covered by ocean, given as a percentage (poorly named). id = register_static_field('ocean_model', 'area_t_percent', diag%axesT1, & diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index e6453cce22..25cba931e6 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1099,7 +1099,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) ! (in) directory - The directory into which to place the file. character(len=240) :: filepath character(len=40) :: mdl = "write_ocean_geometry_file" - integer, parameter :: nFlds=25 + integer, parameter :: nFlds=23 type(vardesc) :: vars(nFlds) type(fieldtype) :: fields(nFlds) integer :: unit @@ -1150,13 +1150,10 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) vars(18)= var_desc("dyCuo","m","Open meridional grid spacing at u points",'u','1','1') vars(19)= var_desc("wet", "nondim", "land or ocean?", 'h','1','1') - vars(20) = var_desc("dx_Cv","m","Modified Zonal grid spacing at v points",'v','1','1') - vars(21) = var_desc("dy_Cu","m","Modified Meridional grid spacing at u points",'u','1','1') - - vars(22) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') - vars(23) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') - vars(24) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') - vars(25) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') + vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') + vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') + vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') + vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') nFlds_used = 21 ; if (G%bathymetry_at_vel) nFlds_used = 25 @@ -1224,16 +1221,11 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) call write_field(unit, fields(18), G%Domain%mpp_domain, G%dy_Cu) call write_field(unit, fields(19), G%Domain%mpp_domain, G%mask2dT) - do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = G%dx_Cv(i,J) ; enddo ; enddo - call write_field(unit, fields(20), G%Domain%mpp_domain, out_v) - do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = G%dy_Cu(I,j) ; enddo ; enddo - call write_field(unit, fields(21), G%Domain%mpp_domain, out_u) - if (G%bathymetry_at_vel) then - call write_field(unit, fields(22), G%Domain%mpp_domain, G%Dblock_u) - call write_field(unit, fields(23), G%Domain%mpp_domain, G%Dopen_u) - call write_field(unit, fields(24), G%Domain%mpp_domain, G%Dblock_v) - call write_field(unit, fields(25), G%Domain%mpp_domain, G%Dopen_v) + call write_field(unit, fields(20), G%Domain%mpp_domain, G%Dblock_u) + call write_field(unit, fields(21), G%Domain%mpp_domain, G%Dopen_u) + call write_field(unit, fields(22), G%Domain%mpp_domain, G%Dblock_v) + call write_field(unit, fields(23), G%Domain%mpp_domain, G%Dopen_v) endif call close_file(unit) From 1686e127a055daa387143a74bb7a89cc34e36250 Mon Sep 17 00:00:00 2001 From: William Cooke Date: Tue, 23 Jan 2018 15:47:52 -0500 Subject: [PATCH 140/170] Corrected indexing of vars array. --- src/initialization/MOM_shared_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 25cba931e6..80976554c8 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1156,7 +1156,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') - nFlds_used = 21 ; if (G%bathymetry_at_vel) nFlds_used = 25 + nFlds_used = 19 ; if (G%bathymetry_at_vel) nFlds_used = 23 if (present(geom_file)) then filepath = trim(directory) // trim(geom_file) From caad823b17a1cbbaa8773d0f0159001e2fbd708e Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 23 Jan 2018 18:30:24 -0500 Subject: [PATCH 141/170] Change WARNING to FATAL for checksum mismatch - Checksum mismatch was meant to be a FATAL condition. It was set to WARNING only for debugging. --- src/framework/MOM_restart.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 565816bdba..b8f3a73b9e 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1254,7 +1254,7 @@ subroutine restore_state(filename, directory, day, G, CS) write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& " does not match value ", checksum_file(1), & " stored in "//trim(unit_path(n)//"." ) - call MOM_error(WARNING, "MOM_restart(restore_state): "//trim(mesg) ) + call MOM_error(FATAL, "MOM_restart(restore_state): "//trim(mesg) ) endif CS%restart_field(m)%initialized = .true. From 767c5e0aba30d332bc7be832241a858b7dc8c2b0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jan 2018 19:10:54 -0500 Subject: [PATCH 142/170] +Moved extra T&S diagnostics into MOM_diagnostics Moved the auxiliary temperature and salinity diagnostics into MOM_diagnostics, and eliminated the routine post_TS_diagnostics. Also replaced the static array CS%diag_tmp3d with the temporary arrays work_3d and work_2d in several places in MOM_diagnostics.F90. All answers are bitwise identical, although the order of entries in the available_diags files changed, and there is a new argument to MOM_diagnostics_init. --- src/core/MOM.F90 | 67 +---------- src/diagnostics/MOM_diagnostics.F90 | 175 ++++++++++++++++++---------- 2 files changed, 118 insertions(+), 124 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 97adcc9aaa..2f5704b6c7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -90,9 +90,8 @@ module MOM use MOM_dynamics_unsplit_RK2, only : initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : MOM_dyn_unsplit_RK2_CS use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid -use MOM_EOS, only : EOS_init +use MOM_EOS, only : EOS_init, calculate_density use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_EOS, only : calculate_density use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type, set_first_direction use MOM_grid, only : MOM_grid_init, MOM_grid_end @@ -153,7 +152,6 @@ module MOM ! 3-d state fields integer :: id_u = -1, id_v = -1, id_h = -1 - integer :: id_Tpot = -1, id_Sprac = -1 ! 2-d surface and bottom fields integer :: id_zos = -1 @@ -169,8 +167,6 @@ module MOM integer :: id_ssv = -1 integer :: id_speed = -1 integer :: id_ssh_inst = -1 - integer :: id_tob = -1 - integer :: id_sob = -1 integer :: id_sstcon = -1 integer :: id_sssabs = -1 @@ -883,7 +879,6 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, fluxes, CS%t_dyn_rel_diag, G, GV, CS%diagnostics_CSp) call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag, G, GV, CS%t_dyn_rel_diag) - call post_TS_diagnostics(IDs, G, GV, CS%tv, CS%diag, CS%t_dyn_rel_diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) CS%t_dyn_rel_diag = 0.0 @@ -2143,7 +2138,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo endif call MOM_diagnostics_init(MOM_internal_state, CS%ADp, CS%CDp, Time, G, GV, & - param_file, diag, CS%diagnostics_CSp) + param_file, diag, CS%diagnostics_CSp, CS%tv) CS%Z_diag_interval = set_time(int((CS%dt_therm) * & max(1,floor(0.01 + Z_diag_int/(CS%dt_therm))))) @@ -2349,12 +2344,6 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) 'Sea Surface Speed', 'm s-1', missing) if (associated(tv%T)) then - IDs%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & - long_name='Sea Water Potential Temperature at Sea Floor', & - standard_name='sea_water_potential_temperature_at_sea_floor', units='degC') - IDs%id_sob = register_diag_field('ocean_model','sob',diag%axesT1, Time, & - long_name='Sea Water Salinity at Sea Floor', & - standard_name='sea_water_salinity_at_sea_floor', units='psu') IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & 'Sea Surface Temperature', 'degC', missing, cmor_field_name='tos', & cmor_long_name='Sea Surface Temperature', & @@ -2372,14 +2361,10 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) cmor_long_name='Square of Sea Surface Salinity ', & cmor_standard_name='square_of_sea_surface_salinity') if (tv%T_is_conT) then - IDs%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, Time, & - 'Potential Temperature', 'degC') IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & 'Sea Surface Conservative Temperature', 'Celsius', missing) endif if (tv%S_is_absS) then - IDs%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, Time, & - 'Salinity', 'psu') IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & 'Sea Surface Absolute Salinity', 'g kg-1', missing) endif @@ -2539,54 +2524,6 @@ function transport_remap_grid_needed(IDs) result(needed) needed = needed .or. (IDs%id_umo > 0) .or. (IDs%id_vmo > 0) end function transport_remap_grid_needed -!> Post diagnostics of temperatures and salinities, their fluxes, and tendencies. -subroutine post_TS_diagnostics(IDs, G, GV, tv, diag, dt) - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - real, intent(in) :: dt !< total time step for T,S update - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: potTemp, pracSal !TEOS10 Diagnostics - real :: work3d(SZI_(G),SZJ_(G),SZK_(G)) - real :: work2d(SZI_(G),SZJ_(G)) - real :: Idt, ppt2mks - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - - if (.NOT.tv%T_is_conT) then - ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_tob > 0) call post_data(IDs%id_tob, tv%T(:,:,G%ke), diag, mask=G%mask2dT) - else - ! Internal T&S variables are conservative temperature & absolute salinity, - ! so they need to converted to potential temperature and practical salinity - ! for some diagnostics using TEOS-10 function calls. - if ((IDs%id_Tpot > 0) .or. (IDs%id_tob > 0)) then - do k=1,nz ; do j=js,je ; do i=is,ie - potTemp(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) - enddo; enddo ; enddo - if (IDs%id_Tpot > 0) call post_data(IDs%id_Tpot, potTemp, diag) - if (IDs%id_tob > 0) call post_data(IDs%id_tob, potTemp(:,:,G%ke), diag, mask=G%mask2dT) - endif - endif - if (.NOT.tv%S_is_absS) then - ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_sob > 0) call post_data(IDs%id_sob, tv%S(:,:,G%ke), diag, mask=G%mask2dT) - else - ! Internal T&S variables are conservative temperature & absolute salinity, - ! so they need to converted to potential temperature and practical salinity - ! for some diagnostics using TEOS-10 function calls. - if ((IDs%id_Sprac > 0) .or. (IDs%id_sob > 0)) then - do k=1,nz ; do j=js,je ; do i=is,ie - pracSal(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) - enddo; enddo ; enddo - if (IDs%id_Sprac > 0) call post_data(IDs%id_Sprac, pracSal, diag) - if (IDs%id_sob > 0) call post_data(IDs%id_sob, pracSal(:,:,G%ke), diag, mask=G%mask2dT) - endif - endif - -end subroutine post_TS_diagnostics !> This routine posts diagnostics of various integrated quantities. subroutine post_integrated_diagnostics(IDs, G, GV, diag, dt_int, tv, ssh, fluxes) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 920dbf9ba8..7a83db96ad 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -32,6 +32,7 @@ module MOM_diagnostics use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East use MOM_EOS, only : calculate_density, int_density_dz +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -105,8 +106,7 @@ module MOM_diagnostics KE_adv => NULL(),& ! KE source from along-layer advection KE_visc => NULL(),& ! KE source from vertical viscosity KE_horvisc => NULL(),& ! KE source from horizontal viscosity - KE_dia => NULL(),& ! KE source from diapycnal diffusion - diag_tmp3d => NULL() ! 3D re-usable arrays for diagnostics + KE_dia => NULL() ! KE source from diapycnal diffusion ! diagnostic IDs integer :: id_e = -1, id_e_D = -1 @@ -128,6 +128,8 @@ module MOM_diagnostics integer :: id_mass_wt = -1, id_col_mass = -1 integer :: id_masscello = -1, id_masso = -1 integer :: id_volcello = -1 + integer :: id_Tpot = -1, id_Sprac = -1 + integer :: id_tob = -1, id_sob = -1 integer :: id_thetaoga = -1, id_soga = -1 integer :: id_sosga = -1, id_tosga = -1 integer :: id_temp_layer_ave = -1, id_salt_layer_ave = -1 @@ -192,6 +194,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & ! coordinate variable potential density, in kg m-3. real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) + ! Two temporary work arrays + real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) + real :: work_2d(SZI_(G),SZJ_(G)) ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) @@ -253,17 +258,18 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & ! mass per area of grid cell (for Bouss, use Rho0) if (CS%id_masscello > 0) then do k=1,nz; do j=js,je ; do i=is,ie - CS%diag_tmp3d(i,j,k) = GV%H_to_kg_m2*h(i,j,k) + work_3d(i,j,k) = GV%H_to_kg_m2*h(i,j,k) enddo ; enddo ; enddo - call post_data(CS%id_masscello, CS%diag_tmp3d, CS%diag) + call post_data(CS%id_masscello, work_3d, CS%diag) endif ! mass of liquid ocean (for Bouss, use Rho0) if (CS%id_masso > 0) then - do k=1,nz; do j=js,je ; do i=is,ie - CS%diag_tmp3d(i,j,k) = GV%H_to_kg_m2*h(i,j,k)*G%areaT(i,j) + work_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work_2d(i,j) = work_2d(i,j) + (GV%H_to_kg_m2*h(i,j,k)) * G%areaT(i,j) enddo ; enddo ; enddo - masso = (reproducing_sum(sum(CS%diag_tmp3d,3))) + masso = reproducing_sum(work_2d) call post_data(CS%id_masso, masso, CS%diag) endif @@ -273,9 +279,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, GV%H_to_m*h, CS%diag) if (CS%id_volcello > 0) then ! volcello = h*area for Boussinesq do k=1,nz; do j=js,je ; do i=is,ie - CS%diag_tmp3d(i,j,k) = ( GV%H_to_m*h(i,j,k) ) * G%areaT(i,j) + work_3d(i,j,k) = ( GV%H_to_m*h(i,j,k) ) * G%areaT(i,j) enddo ; enddo ; enddo - call post_data(CS%id_volcello, CS%diag_tmp3d, CS%diag) + call post_data(CS%id_volcello, work_3d, CS%diag) endif else ! thkcello = dp/(rho*g) for non-Boussinesq do j=js,je @@ -292,27 +298,61 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & do i=is,ie ! Pressure for EOS at the layer center (Pa) pressure_1d(i) = pressure_1d(i) + 0.5*(GV%g_Earth*GV%H_to_kg_m2)*h(i,j,k) enddo - ! Store in-situ density (kg/m3) in diag_tmp3d + ! Store in-situ density (kg/m3) in work_3d call calculate_density(tv%T(:,j,k),tv%S(:,j,k), pressure_1d, & - CS%diag_tmp3d(:,j,k), is, ie-is+1, tv%eqn_of_state) - do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in diag_tmp3d - CS%diag_tmp3d(i,j,k) = (GV%H_to_kg_m2*h(i,j,k))/CS%diag_tmp3d(i,j,k) + work_3d(:,j,k), is, ie-is+1, tv%eqn_of_state) + do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d + work_3d(i,j,k) = (GV%H_to_kg_m2*h(i,j,k)) / work_3d(i,j,k) enddo do i=is,ie ! Pressure for EOS at the bottom interface (Pa) pressure_1d(i) = pressure_1d(i) + 0.5*(GV%g_Earth*GV%H_to_kg_m2)*h(i,j,k) enddo enddo ! k enddo ! j - if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, CS%diag_tmp3d, CS%diag) + if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, work_3d, CS%diag) if (CS%id_volcello > 0) then do k=1,nz; do j=js,je ; do i=is,ie ! volcello = dp/(rho*g)*area for non-Boussinesq - CS%diag_tmp3d(i,j,k) = G%areaT(i,j) * CS%diag_tmp3d(i,j,k) + work_3d(i,j,k) = G%areaT(i,j) * work_3d(i,j,k) enddo ; enddo ; enddo - call post_data(CS%id_volcello, CS%diag_tmp3d, CS%diag) + call post_data(CS%id_volcello, work_3d, CS%diag) endif endif endif + ! Calculate additional, potentially derived temperature diagnostics + if (tv%T_is_conT) then + ! Internal T&S variables are conservative temperature & absolute salinity, + ! so they need to converted to potential temperature and practical salinity + ! for some diagnostics using TEOS-10 function calls. + if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0)) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) + enddo; enddo ; enddo + if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, work_3d, CS%diag) + if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) + endif + else + ! Internal T&S variables are potential temperature & practical salinity + if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,nz), CS%diag, mask=G%mask2dT) + endif + + ! Calculate additional, potentially derived salinity diagnostics + if (tv%S_is_absS) then + ! Internal T&S variables are conservative temperature & absolute salinity, + ! so they need to converted to potential temperature and practical salinity + ! for some diagnostics using TEOS-10 function calls. + if ((CS%id_Sprac > 0) .or. (CS%id_sob > 0)) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) + enddo; enddo ; enddo + if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, work_3d, CS%diag) + if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) + endif + else + ! Internal T&S variables are potential temperature & practical salinity + if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,nz), CS%diag, mask=G%mask2dT) + endif + ! volume mean potential temperature if (CS%id_thetaoga>0) then thetaoga = global_volume_mean(tv%T, h, G, GV) @@ -1074,8 +1114,9 @@ subroutine calculate_derivs(dt, G, CS) end subroutine calculate_derivs -! #@# This subroutine needs a doxygen description -subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS) +!> This subroutine registers various diagnostics and allocates space for fields +!! that other diagnostis depend upon. +subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS, tv) type(ocean_internal_state), intent(in) :: MIS !< For "MOM Internal State" a set of pointers to !! the fields and accelerations that make up the !! ocean's internal physical state. @@ -1091,6 +1132,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. type(diagnostics_CS), pointer :: CS !< Pointer set to point to control structure !! for this module. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. ! Arguments ! (in) MIS - For "MOM Internal State" a set of pointers to the fields and @@ -1112,6 +1155,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. real :: omega, f2_min, convert_H character(len=48) :: thickness_units, flux_units + logical :: use_temperature integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j @@ -1128,6 +1172,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS allocate(CS) CS%diag => diag + use_temperature = ASSOCIATED(tv%T) + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version) @@ -1146,12 +1192,6 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS thickness_units = "kg m-2" ; flux_units = "kg s-1" ; convert_H = GV%H_to_kg_m2 endif - CS%id_temp_layer_ave = register_diag_field('ocean_model', 'temp_layer_ave', diag%axesZL, Time, & - 'Layer Average Ocean Temperature', 'degC') - - CS%id_salt_layer_ave = register_diag_field('ocean_model', 'salt_layer_ave', diag%axesZL, Time, & - 'Layer Average Ocean Salinity', 'psu') - CS%id_masscello = register_diag_field('ocean_model', 'masscello', diag%axesTL,& Time, 'Mass per unit area of liquid ocean grid cell', 'kg m-2', & standard_name='sea_water_mass_per_unit_area', v_extensive=.true.) @@ -1167,30 +1207,46 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS ! by this module. CS%id_volcello = diag_get_volume_cell_measure_dm_id(diag) - if ((((CS%id_masscello>0) .or. (CS%id_masso>0) .or. (CS%id_volcello>0) .or. & - (CS%id_thkcello>0.and..not.GV%Boussinesq)) ) .and. .not.ASSOCIATED(CS%diag_tmp3d)) then - call safe_alloc_ptr(CS%diag_tmp3d,isd,ied,jsd,jed,nz) - endif - - CS%id_thetaoga = register_scalar_field('ocean_model', 'thetaoga', & - Time, diag, 'Global Mean Ocean Potential Temperature', 'degC',& - standard_name='sea_water_potential_temperature') - - CS%id_soga = register_scalar_field('ocean_model', 'soga', & - Time, diag, 'Global Mean Ocean Salinity', 'psu', & - standard_name='sea_water_salinity') - - CS%id_tosga = register_scalar_field('ocean_model', 'sst_global', Time, diag,& - long_name='Global Area Average Sea Surface Temperature', & - units='degC', standard_name='sea_surface_temperature', & - cmor_field_name='tosga', cmor_standard_name='sea_surface_temperature', & - cmor_long_name='Sea Surface Temperature') + if (use_temperature) then + if (tv%T_is_conT) then + CS%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, & + Time, 'Potential Temperature', 'degC') + endif + if (tv%S_is_absS) then + CS%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, & + Time, 'Salinity', 'psu') + endif - CS%id_sosga = register_scalar_field('ocean_model', 'sss_global', Time, diag,& - long_name='Global Area Average Sea Surface Salinity', & - units='psu', standard_name='sea_surface_salinity', & - cmor_field_name='sosga', cmor_standard_name='sea_surface_salinity', & - cmor_long_name='Sea Surface Salinity') + CS%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & + long_name='Sea Water Potential Temperature at Sea Floor', & + standard_name='sea_water_potential_temperature_at_sea_floor', units='degC') + CS%id_sob = register_diag_field('ocean_model','sob',diag%axesT1, Time, & + long_name='Sea Water Salinity at Sea Floor', & + standard_name='sea_water_salinity_at_sea_floor', units='psu') + + CS%id_temp_layer_ave = register_diag_field('ocean_model', 'temp_layer_ave', & + diag%axesZL, Time, 'Layer Average Ocean Temperature', 'degC') + CS%id_salt_layer_ave = register_diag_field('ocean_model', 'salt_layer_ave', & + diag%axesZL, Time, 'Layer Average Ocean Salinity', 'psu') + + CS%id_thetaoga = register_scalar_field('ocean_model', 'thetaoga', & + Time, diag, 'Global Mean Ocean Potential Temperature', 'degC',& + standard_name='sea_water_potential_temperature') + CS%id_soga = register_scalar_field('ocean_model', 'soga', & + Time, diag, 'Global Mean Ocean Salinity', 'psu', & + standard_name='sea_water_salinity') + + CS%id_tosga = register_scalar_field('ocean_model', 'sst_global', Time, diag,& + long_name='Global Area Average Sea Surface Temperature', & + units='degC', standard_name='sea_surface_temperature', & + cmor_field_name='tosga', cmor_standard_name='sea_surface_temperature', & + cmor_long_name='Sea Surface Temperature') + CS%id_sosga = register_scalar_field('ocean_model', 'sss_global', Time, diag,& + long_name='Global Area Average Sea Surface Salinity', & + units='psu', standard_name='sea_surface_salinity', & + cmor_field_name='sosga', cmor_standard_name='sea_surface_salinity', & + cmor_long_name='Sea Surface Salinity') + endif CS%id_e = register_diag_field('ocean_model', 'e', diag%axesTi, Time, & 'Interface Height Relative to Mean Sea Level', 'm') @@ -1331,17 +1387,19 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & 'The column mass for calculating mass-weighted average properties', 'kg m-2') - CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & - 'Density weighted column integrated potential temperature', 'degC kg m-2', & - cmor_field_name='opottempmint', & - cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature',& - cmor_standard_name='Depth integrated density times potential temperature') - - CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & - 'Density weighted column integrated salinity', 'psu kg m-2', & - cmor_field_name='somint', & - cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity',& - cmor_standard_name='Depth integrated density times salinity') + if (use_temperature) then + CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & + 'Density weighted column integrated potential temperature', 'degC kg m-2', & + cmor_field_name='opottempmint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature',& + cmor_standard_name='Depth integrated density times potential temperature') + + CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & + 'Density weighted column integrated salinity', 'psu kg m-2', & + cmor_field_name='somint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity',& + cmor_standard_name='Depth integrated density times salinity') + endif CS%id_col_mass = register_diag_field('ocean_model', 'col_mass', diag%axesT1, Time, & 'The column integrated in situ density', 'kg m-2') @@ -1447,7 +1505,6 @@ subroutine MOM_diagnostics_end(CS, ADp) if (ASSOCIATED(CS%vh_Rlay)) deallocate(CS%vh_Rlay) if (ASSOCIATED(CS%uhGM_Rlay)) deallocate(CS%uhGM_Rlay) if (ASSOCIATED(CS%vhGM_Rlay)) deallocate(CS%vhGM_Rlay) - if (ASSOCIATED(CS%diag_tmp3d)) deallocate(CS%diag_tmp3d) if (ASSOCIATED(ADp%gradKEu)) deallocate(ADp%gradKEu) if (ASSOCIATED(ADp%gradKEu)) deallocate(ADp%gradKEu) From a974ee124f886f81a2fa137c6b06302a40744da3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jan 2018 19:46:51 -0500 Subject: [PATCH 143/170] +Combine surface and integrated diagnostic routines Combined post_integrated_diagnostics into post_surface_diagnostics, including modifications to reduce the number of temporary arrays in use. Also regrouped the tracer registration calls to reflect where various diagnostics fit in the overall algorithm. ALl answers are diagnostics are bitwise identical. --- src/core/MOM.F90 | 181 ++++++++++++++++++----------------------------- 1 file changed, 69 insertions(+), 112 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2f5704b6c7..10f8e84462 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -920,8 +920,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! Do diagnostics that only occur at the end of a complete forcing step. call cpu_clock_begin(id_clock_diagnostics) call enable_averaging(dt*n_max, Time_local, CS%diag) - call post_integrated_diagnostics(IDs, G, GV, CS%diag, dt*n_max, CS%tv, ssh, fluxes) - call post_surface_diagnostics(IDs, G, CS%diag, sfc_state, CS%tv) + call post_surface_diagnostics(IDs, G, GV, CS%diag, dt*n_max, sfc_state, CS%tv, ssh, fluxes) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -2311,6 +2310,7 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) H_convert = GV%H_to_kg_m2 endif + ! Diagnostics of the rapidly varying dynamic state IDs%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & 'Zonal velocity', 'm s-1', cmor_field_name='uo', & cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') @@ -2319,7 +2319,10 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') IDs%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & 'Layer Thickness', thickness_units, v_extensive=.true., conversion=H_convert) + IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, Time, & + 'Instantaneous Sea Surface Height', 'm', missing) + ! Vertically integrated, budget, and surface state diagnostics IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& long_name='Total volume of liquid ocean', units='m3', & standard_name='sea_water_volume') @@ -2334,8 +2337,6 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& long_name='Area averaged sea surface height', units='m', & standard_name='area_averaged_sea_surface_height') - IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, Time, & - 'Instantaneous Sea Surface Height', 'm', missing) IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & 'Sea Surface Zonal Velocity', 'm s-1', missing) IDs%id_ssv = register_diag_field('ocean_model', 'SSV', diag%axesCv1, Time, & @@ -2383,7 +2384,7 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') - ! Diagnostics related to tracer transport + ! Diagnostics related to tracer and mass transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & 'Accumulated zonal thickness fluxes to advect tracers', 'kg', & y_cell_method='sum', v_extensive=.true., conversion=H_convert) @@ -2525,36 +2526,29 @@ function transport_remap_grid_needed(IDs) result(needed) end function transport_remap_grid_needed -!> This routine posts diagnostics of various integrated quantities. -subroutine post_integrated_diagnostics(IDs, G, GV, diag, dt_int, tv, ssh, fluxes) +!> This routine posts diagnostics of various ocean surface and integrated +!! quantities at the time the ocean state is reported back to the caller +subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, ssh, fluxes) type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output real, intent(in) :: dt_int !< total time step associated with these diagnostics, in s. + type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ssh !< Time mean surface height without !! corrections for ice displacement(m) type(forcing), intent(in) :: fluxes !< pointers to forcing fields - real, allocatable, dimension(:,:) :: & - tmp, & ! temporary 2d field - zos, & ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh (meter) - zossq, & ! square of zos (m^2) - sfc_speed, & ! sea surface speed at h-points (m/s) - frazil_ave, & ! average frazil heat flux required to keep temp above freezing (W/m2) - salt_deficit_ave, & ! average salt flux required to keep salinity above 0.01ppt (gSalt m-2 s-1) - Heat_PmE_ave, & ! average effective heat flux into the ocean due to - ! the exchange of water with other components, times the - ! heat capacity of water, in W m-2. - intern_heat_ave ! avg heat flux into ocean from geothermal or - ! other internal heat sources (W/m2) + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + real, dimension(SZI_(G),SZJ_(G)) :: & + zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh (meter) real :: I_time_int ! The inverse of the time interval in s-1. real :: zos_area_mean, volo, ssh_ga - integer :: i, j, k, is, ie, js, je, nz! , Isq, Ieq, Jsq, Jeq + integer :: i, j, is, ie, js, je - 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 ! area mean SSH if (IDs%id_ssh_ga > 0) then @@ -2569,147 +2563,110 @@ subroutine post_integrated_diagnostics(IDs, G, GV, diag, dt_int, tv, ssh, fluxes ! post the dynamic sea level, zos, and zossq. ! zos is ave_ssh with sea ice inverse barometer removed, ! and with zero global area mean. - if(IDs%id_zos > 0 .or. IDs%id_zossq > 0) then - allocate(zos(G%isd:G%ied,G%jsd:G%jed)) - zos(:,:) = 0.0 - do j=js,je ; do i=is,ie - zos(i,j) = ssh(i,j) - enddo ; enddo - if (ASSOCIATED(fluxes%p_surf)) then - do j=js,je ; do i=is,ie - zos(i,j) = zos(i,j) + G%mask2dT(i,j)*fluxes%p_surf(i,j) / & - (GV%Rho0 * GV%g_Earth) - enddo ; enddo - endif - zos_area_mean = global_area_mean(zos, G) - do j=js,je ; do i=is,ie - zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean - enddo ; enddo - if(IDs%id_zos > 0) then - call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) - endif - if(IDs%id_zossq > 0) then - allocate(zossq(G%isd:G%ied,G%jsd:G%jed)) - zossq(:,:) = 0.0 - do j=js,je ; do i=is,ie - zossq(i,j) = zos(i,j)*zos(i,j) - enddo ; enddo - call post_data(IDs%id_zossq, zossq, diag, mask=G%mask2dT) - deallocate(zossq) - endif - deallocate(zos) + if (IDs%id_zos > 0 .or. IDs%id_zossq > 0) then + zos(:,:) = 0.0 + do j=js,je ; do i=is,ie + zos(i,j) = ssh(i,j) + enddo ; enddo + if (ASSOCIATED(fluxes%p_surf)) then + do j=js,je ; do i=is,ie + zos(i,j) = zos(i,j) + G%mask2dT(i,j)*fluxes%p_surf(i,j) / & + (GV%Rho0 * GV%g_Earth) + enddo ; enddo + endif + zos_area_mean = global_area_mean(zos, G) + do j=js,je ; do i=is,ie + zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean + enddo ; enddo + if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) + if (IDs%id_zossq > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = zos(i,j)*zos(i,j) + enddo ; enddo + call post_data(IDs%id_zossq, work_2d, diag, mask=G%mask2dT) + endif endif ! post total volume of the liquid ocean - if(IDs%id_volo > 0) then - allocate(tmp(G%isd:G%ied,G%jsd:G%jed)) + if (IDs%id_volo > 0) then do j=js,je ; do i=is,ie - tmp(i,j) = G%mask2dT(i,j)*(ssh(i,j) + G%bathyT(i,j)) + work_2d(i,j) = G%mask2dT(i,j)*(ssh(i,j) + G%bathyT(i,j)) enddo ; enddo - volo = global_area_integral(tmp, G) + volo = global_area_integral(work_2d, G) call post_data(IDs%id_volo, volo, diag) - deallocate(tmp) endif - ! post frazil + ! post time-averaged rate of frazil formation if (ASSOCIATED(tv%frazil) .and. (IDs%id_fraz > 0)) then - allocate(frazil_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie - frazil_ave(i,j) = tv%frazil(i,j) * I_time_int + work_2d(i,j) = tv%frazil(i,j) * I_time_int enddo ; enddo - call post_data(IDs%id_fraz, frazil_ave, diag, mask=G%mask2dT) - deallocate(frazil_ave) + call post_data(IDs%id_fraz, work_2d, diag, mask=G%mask2dT) endif - ! post the salt deficit + ! post time-averaged salt deficit if (ASSOCIATED(tv%salt_deficit) .and. (IDs%id_salt_deficit > 0)) then - allocate(salt_deficit_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie - salt_deficit_ave(i,j) = tv%salt_deficit(i,j) * I_time_int + work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int enddo ; enddo - call post_data(IDs%id_salt_deficit, salt_deficit_ave, diag, mask=G%mask2dT) - deallocate(salt_deficit_ave) + call post_data(IDs%id_salt_deficit, work_2d, diag, mask=G%mask2dT) endif ! post temperature of P-E+R if (ASSOCIATED(tv%TempxPmE) .and. (IDs%id_Heat_PmE > 0)) then - allocate(Heat_PmE_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie - Heat_PmE_ave(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) + work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(IDs%id_Heat_PmE, Heat_PmE_ave, diag, mask=G%mask2dT) - deallocate(Heat_PmE_ave) + call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) endif ! post geothermal heating or internal heat source/sinks if (ASSOCIATED(tv%internal_heat) .and. (IDs%id_intern_heat > 0)) then - allocate(intern_heat_ave(G%isd:G%ied,G%jsd:G%jed)) do j=js,je ; do i=is,ie - intern_heat_ave(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) + work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(IDs%id_intern_heat, intern_heat_ave, diag, mask=G%mask2dT) - deallocate(intern_heat_ave) + call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) endif -end subroutine post_integrated_diagnostics - -!> This routine posts diagnostics of various ocean surface quantities. -subroutine post_surface_diagnostics(IDs, G, diag, sfc_state, tv) - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - type(surface), intent(in) :: sfc_state !< ocean surface state - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - - real, dimension(SZI_(G),SZJ_(G)) :: & - potTemp, & ! TEOS10 potential temperature (deg C) - pracSal, & ! TEOS10 practical salinity - SST_sq, & ! Surface temperature squared, in degC^2 - SSS_sq, & ! Surface salinity squared, in salnity units^2 - sfc_speed ! sea surface speed at h-points (m/s) - - integer :: i, j, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - if (.NOT.tv%T_is_conT) then - ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) - else + if (tv%T_is_conT) then ! Internal T&S variables are conservative temperature & absolute salinity if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp ! to potential temperature. do j=js,je ; do i=is,ie - potTemp(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j),sfc_state%SST(i,j)) + work_2d(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j),sfc_state%SST(i,j)) enddo ; enddo - if (IDs%id_sst > 0) call post_data(IDs%id_sst, potTemp, diag, mask=G%mask2dT) - endif - if (.NOT.tv%S_is_absS) then - ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) + if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag, mask=G%mask2dT) else + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) + endif + + if (tv%S_is_absS) then ! Internal T&S variables are conservative temperature & absolute salinity if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) ! Use TEOS-10 function calls convert T&S diagnostics from absolute salinity ! to practical salinity. do j=js,je ; do i=is,ie - pracSal(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) + work_2d(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) enddo ; enddo - if (IDs%id_sss > 0) call post_data(IDs%id_sss, pracSal, diag, mask=G%mask2dT) + if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag, mask=G%mask2dT) + else + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) endif if (IDs%id_sst_sq > 0) then do j=js,je ; do i=is,ie - SST_sq(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j) + work_2d(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j) enddo ; enddo - call post_data(IDs%id_sst_sq, SST_sq, diag, mask=G%mask2dT) + call post_data(IDs%id_sst_sq, work_2d, diag, mask=G%mask2dT) endif if (IDs%id_sss_sq > 0) then do j=js,je ; do i=is,ie - SSS_sq(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j) + work_2d(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j) enddo ; enddo - call post_data(IDs%id_sss_sq, SSS_sq, diag, mask=G%mask2dT) + call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif if (IDs%id_ssu > 0) & @@ -2719,10 +2676,10 @@ subroutine post_surface_diagnostics(IDs, G, diag, sfc_state, tv) if (IDs%id_speed > 0) then do j=js,je ; do i=is,ie - sfc_speed(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & + work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) enddo ; enddo - call post_data(IDs%id_speed, sfc_speed, diag, mask=G%mask2dT) + call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) endif call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) From 3e5e8249e81acec37e098f7518261dc03f45ab37 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jan 2018 20:59:55 -0500 Subject: [PATCH 144/170] +Separated surface and state diagnostics Separated MOM_diag_IDs from surface_diag_IDs and register_surface_diags from register_diags. Also eliminated unused arguments to both registration routines. All answers are bitwise identical, but there are interface changes. --- src/core/MOM.F90 | 96 ++++++++++++++++++++++++++---------------------- 1 file changed, 53 insertions(+), 43 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 10f8e84462..59881c2f14 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -146,13 +146,20 @@ module MOM #include -!> A structure with diagnostic IDs +!> A structure with diagnostic IDs of the state variables type MOM_diag_IDs - ! diagnostic ids - ! 3-d state fields integer :: id_u = -1, id_v = -1, id_h = -1 + ! 2-d state field + integer :: id_ssh_inst = -1 + ! Diagnostics for tracer horizontal transport + integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = -1 + integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 +end type MOM_diag_IDs + +!> A structure with diagnostic IDs of the surface and integrated variables +type surface_diag_IDs ! 2-d surface and bottom fields integer :: id_zos = -1 integer :: id_zossq = -1 @@ -166,7 +173,6 @@ module MOM integer :: id_ssu = -1 integer :: id_ssv = -1 integer :: id_speed = -1 - integer :: id_ssh_inst = -1 integer :: id_sstcon = -1 integer :: id_sssabs = -1 @@ -175,11 +181,7 @@ module MOM integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - - ! Diagnostics for tracer horizontal transport - integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = -1 - integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 -end type MOM_diag_IDs +end type surface_diag_IDs !> Control structure for this module type, public :: MOM_control_struct @@ -313,6 +315,7 @@ module MOM logical :: tendency_diagnostics = .false. type(MOM_diag_IDs) :: IDs + type(surface_diag_IDs) :: sfc_IDs ! The remainder provides pointers to child module control structures. type(MOM_dyn_unsplit_CS), pointer :: dyn_unsplit_CSp => NULL() @@ -920,7 +923,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! Do diagnostics that only occur at the end of a complete forcing step. call cpu_clock_begin(id_clock_diagnostics) call enable_averaging(dt*n_max, Time_local, CS%diag) - call post_surface_diagnostics(IDs, G, GV, CS%diag, dt*n_max, sfc_state, CS%tv, ssh, fluxes) + call post_surface_diagnostics(CS%sfc_IDs, G, GV, CS%diag, dt*n_max, sfc_state, CS%tv, ssh, fluxes) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -1423,7 +1426,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. real :: conv2watt, conv2salt, H_convert - character(len=48) :: thickness_units, flux_units, S_flux_units + character(len=48) :: flux_units, S_flux_units type(time_type) :: Start_time type(ocean_internal_state) :: MOM_internal_state @@ -2167,7 +2170,8 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call callTree_waypoint("tracer registry now locked (initialize_MOM)") ! now register some diagnostics since the tracer registry is now locked - call register_diags(Time, G, GV, CS%IDs, CS%diag, CS%tv%C_p, CS%missing, CS%tv) + call register_surface_diags(Time, G, CS%sfc_IDs, CS%diag, CS%missing, CS%tv) + call register_diags(Time, G, GV, CS%IDs, CS%diag, CS%missing) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & CS%use_ALE_algorithm, CS%diag_to_Z_CSp) if (CS%use_ALE_algorithm) then @@ -2287,40 +2291,13 @@ subroutine finish_MOM_initialization(Time, dirs, CS, fluxes) end subroutine finish_MOM_initialization !> Register certain diagnostics -subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) +subroutine register_surface_diags(Time, G, IDs, diag, missing, tv) type(time_type), intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(surface_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real, intent(in) :: C_p !< Heat capacity used in conversion to watts real, intent(in) :: missing !< The value to use to fill in missing data - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - - real :: H_convert - character(len=48) :: thickness_units - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - thickness_units = get_thickness_units(GV) - if (GV%Boussinesq) then - H_convert = GV%H_to_m - else - H_convert = GV%H_to_kg_m2 - endif - - ! Diagnostics of the rapidly varying dynamic state - IDs%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & - 'Zonal velocity', 'm s-1', cmor_field_name='uo', & - cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') - IDs%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & - 'Meridional velocity', 'm s-1', cmor_field_name='vo', & - cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') - IDs%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & - 'Layer Thickness', thickness_units, v_extensive=.true., conversion=H_convert) - IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, Time, & - 'Instantaneous Sea Surface Height', 'm', missing) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables ! Vertically integrated, budget, and surface state diagnostics IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& @@ -2384,6 +2361,39 @@ subroutine register_diags(Time, G, GV, IDs, diag, C_p, missing, tv) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') +end subroutine register_surface_diags + +!> Register certain diagnostics +subroutine register_diags(Time, G, GV, IDs, diag, missing) + type(time_type), intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + real, intent(in) :: missing !< The value to use to fill in missing data + + real :: H_convert + character(len=48) :: thickness_units + + thickness_units = get_thickness_units(GV) + if (GV%Boussinesq) then + H_convert = GV%H_to_m + else + H_convert = GV%H_to_kg_m2 + endif + + ! Diagnostics of the rapidly varying dynamic state + IDs%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & + 'Zonal velocity', 'm s-1', cmor_field_name='uo', & + cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') + IDs%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & + 'Meridional velocity', 'm s-1', cmor_field_name='vo', & + cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') + IDs%id_h = register_diag_field('ocean_model', 'h', diag%axesTL, Time, & + 'Layer Thickness', thickness_units, v_extensive=.true., conversion=H_convert) + IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, Time, & + 'Instantaneous Sea Surface Height', 'm', missing) + ! Diagnostics related to tracer and mass transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & 'Accumulated zonal thickness fluxes to advect tracers', 'kg', & @@ -2529,7 +2539,7 @@ end function transport_remap_grid_needed !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, ssh, fluxes) - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output From 800a844e415287f9bdf577c58e0ecf32972b5e23 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jan 2018 21:46:05 -0500 Subject: [PATCH 145/170] +Moved surface diagnostics to MOM_diagnostics.F90 Moved surface_diag_IDs, register_surface_diags, and post_surface_diagnostics from MOM.F90 to MOM_diagnostics.F90. All answers and diagnostics are bitwise identical, but the modules with which a public type and three routines are associated change. --- src/core/MOM.F90 | 262 +------------------------- src/diagnostics/MOM_diagnostics.F90 | 276 +++++++++++++++++++++++++++- 2 files changed, 272 insertions(+), 266 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 59881c2f14..178ddbc1d4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -76,7 +76,8 @@ module MOM use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init -use MOM_diagnostics, only : diagnostics_CS +use MOM_diagnostics, only : diagnostics_CS, surface_diag_IDs +use MOM_diagnostics, only : register_surface_diags, post_surface_diagnostics use MOM_diag_to_Z, only : calculate_Z_diag_fields, calculate_Z_transport use MOM_diag_to_Z, only : MOM_diag_to_Z_init, register_Z_tracer, diag_to_Z_CS use MOM_diag_to_Z, only : MOM_diag_to_Z_end @@ -158,31 +159,6 @@ module MOM integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 end type MOM_diag_IDs -!> A structure with diagnostic IDs of the surface and integrated variables -type surface_diag_IDs - ! 2-d surface and bottom fields - integer :: id_zos = -1 - integer :: id_zossq = -1 - integer :: id_volo = -1 - integer :: id_ssh = -1 - integer :: id_ssh_ga = -1 - integer :: id_sst = -1 - integer :: id_sst_sq = -1 - integer :: id_sss = -1 - integer :: id_sss_sq = -1 - integer :: id_ssu = -1 - integer :: id_ssv = -1 - integer :: id_speed = -1 - integer :: id_sstcon = -1 - integer :: id_sssabs = -1 - - ! heat and salt flux fields - integer :: id_fraz = -1 - integer :: id_salt_deficit = -1 - integer :: id_Heat_PmE = -1 - integer :: id_intern_heat = -1 -end type surface_diag_IDs - !> Control structure for this module type, public :: MOM_control_struct real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: & @@ -2290,79 +2266,6 @@ subroutine finish_MOM_initialization(Time, dirs, CS, fluxes) end subroutine finish_MOM_initialization -!> Register certain diagnostics -subroutine register_surface_diags(Time, G, IDs, diag, missing, tv) - type(time_type), intent(in) :: Time !< current model time - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(surface_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. - type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real, intent(in) :: missing !< The value to use to fill in missing data - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - - ! Vertically integrated, budget, and surface state diagnostics - IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& - long_name='Total volume of liquid ocean', units='m3', & - standard_name='sea_water_volume') - IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& - standard_name = 'sea_surface_height_above_geoid', & - long_name= 'Sea surface height above geoid', units='m', missing_value=missing) - IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& - standard_name='square_of_sea_surface_height_above_geoid', & - long_name='Square of sea surface height above geoid', units='m2', missing_value=missing) - IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & - 'Sea Surface Height', 'm', missing) - IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& - long_name='Area averaged sea surface height', units='m', & - standard_name='area_averaged_sea_surface_height') - IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & - 'Sea Surface Zonal Velocity', 'm s-1', missing) - IDs%id_ssv = register_diag_field('ocean_model', 'SSV', diag%axesCv1, Time, & - 'Sea Surface Meridional Velocity', 'm s-1', missing) - IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & - 'Sea Surface Speed', 'm s-1', missing) - - if (associated(tv%T)) then - IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & - 'Sea Surface Temperature', 'degC', missing, cmor_field_name='tos', & - cmor_long_name='Sea Surface Temperature', & - cmor_standard_name='sea_surface_temperature') - IDs%id_sst_sq = register_diag_field('ocean_model', 'SST_sq', diag%axesT1, Time, & - 'Sea Surface Temperature Squared', 'degC2', missing, cmor_field_name='tossq', & - cmor_long_name='Square of Sea Surface Temperature ', & - cmor_standard_name='square_of_sea_surface_temperature') - IDs%id_sss = register_diag_field('ocean_model', 'SSS', diag%axesT1, Time, & - 'Sea Surface Salinity', 'psu', missing, cmor_field_name='sos', & - cmor_long_name='Sea Surface Salinity', & - cmor_standard_name='sea_surface_salinity') - IDs%id_sss_sq = register_diag_field('ocean_model', 'SSS_sq', diag%axesT1, Time, & - 'Sea Surface Salinity Squared', 'psu', missing, cmor_field_name='sossq', & - cmor_long_name='Square of Sea Surface Salinity ', & - cmor_standard_name='square_of_sea_surface_salinity') - if (tv%T_is_conT) then - IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & - 'Sea Surface Conservative Temperature', 'Celsius', missing) - endif - if (tv%S_is_absS) then - IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & - 'Sea Surface Absolute Salinity', 'g kg-1', missing) - endif - if (ASSOCIATED(tv%frazil)) then - IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & - 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & - cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & - cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') - endif - endif - - IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & - 'Salt sink in ocean due to ice flux', 'psu m-2 s-1') - IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & - 'Heat flux into ocean from mass flux into ocean', 'W m-2') - IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& - 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') - -end subroutine register_surface_diags - !> Register certain diagnostics subroutine register_diags(Time, G, GV, IDs, diag, missing) type(time_type), intent(in) :: Time !< current model time @@ -2536,167 +2439,6 @@ function transport_remap_grid_needed(IDs) result(needed) end function transport_remap_grid_needed -!> This routine posts diagnostics of various ocean surface and integrated -!! quantities at the time the ocean state is reported back to the caller -subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, ssh, fluxes) - type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - real, intent(in) :: dt_int !< total time step associated with these diagnostics, in s. - type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: ssh !< Time mean surface height without - !! corrections for ice displacement(m) - type(forcing), intent(in) :: fluxes !< pointers to forcing fields - - real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array - real, dimension(SZI_(G),SZJ_(G)) :: & - zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh (meter) - real :: I_time_int ! The inverse of the time interval in s-1. - real :: zos_area_mean, volo, ssh_ga - integer :: i, j, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! area mean SSH - if (IDs%id_ssh_ga > 0) then - ssh_ga = global_area_mean(ssh, G) - call post_data(IDs%id_ssh_ga, ssh_ga, diag) - endif - - I_time_int = 1.0 / dt_int - if (IDs%id_ssh > 0) & - call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) - - ! post the dynamic sea level, zos, and zossq. - ! zos is ave_ssh with sea ice inverse barometer removed, - ! and with zero global area mean. - if (IDs%id_zos > 0 .or. IDs%id_zossq > 0) then - zos(:,:) = 0.0 - do j=js,je ; do i=is,ie - zos(i,j) = ssh(i,j) - enddo ; enddo - if (ASSOCIATED(fluxes%p_surf)) then - do j=js,je ; do i=is,ie - zos(i,j) = zos(i,j) + G%mask2dT(i,j)*fluxes%p_surf(i,j) / & - (GV%Rho0 * GV%g_Earth) - enddo ; enddo - endif - zos_area_mean = global_area_mean(zos, G) - do j=js,je ; do i=is,ie - zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean - enddo ; enddo - if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) - if (IDs%id_zossq > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = zos(i,j)*zos(i,j) - enddo ; enddo - call post_data(IDs%id_zossq, work_2d, diag, mask=G%mask2dT) - endif - endif - - ! post total volume of the liquid ocean - if (IDs%id_volo > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = G%mask2dT(i,j)*(ssh(i,j) + G%bathyT(i,j)) - enddo ; enddo - volo = global_area_integral(work_2d, G) - call post_data(IDs%id_volo, volo, diag) - endif - - ! post time-averaged rate of frazil formation - if (ASSOCIATED(tv%frazil) .and. (IDs%id_fraz > 0)) then - do j=js,je ; do i=is,ie - work_2d(i,j) = tv%frazil(i,j) * I_time_int - enddo ; enddo - call post_data(IDs%id_fraz, work_2d, diag, mask=G%mask2dT) - endif - - ! post time-averaged salt deficit - if (ASSOCIATED(tv%salt_deficit) .and. (IDs%id_salt_deficit > 0)) then - do j=js,je ; do i=is,ie - work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int - enddo ; enddo - call post_data(IDs%id_salt_deficit, work_2d, diag, mask=G%mask2dT) - endif - - ! post temperature of P-E+R - if (ASSOCIATED(tv%TempxPmE) .and. (IDs%id_Heat_PmE > 0)) then - do j=js,je ; do i=is,ie - work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) - enddo ; enddo - call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) - endif - - ! post geothermal heating or internal heat source/sinks - if (ASSOCIATED(tv%internal_heat) .and. (IDs%id_intern_heat > 0)) then - do j=js,je ; do i=is,ie - work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) - enddo ; enddo - call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) - endif - - if (tv%T_is_conT) then - ! Internal T&S variables are conservative temperature & absolute salinity - if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) - ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp - ! to potential temperature. - do j=js,je ; do i=is,ie - work_2d(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j),sfc_state%SST(i,j)) - enddo ; enddo - if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag, mask=G%mask2dT) - else - ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) - endif - - if (tv%S_is_absS) then - ! Internal T&S variables are conservative temperature & absolute salinity - if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) - ! Use TEOS-10 function calls convert T&S diagnostics from absolute salinity - ! to practical salinity. - do j=js,je ; do i=is,ie - work_2d(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) - enddo ; enddo - if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag, mask=G%mask2dT) - else - ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) - endif - - if (IDs%id_sst_sq > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j) - enddo ; enddo - call post_data(IDs%id_sst_sq, work_2d, diag, mask=G%mask2dT) - endif - if (IDs%id_sss_sq > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j) - enddo ; enddo - call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) - endif - - if (IDs%id_ssu > 0) & - call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) - if (IDs%id_ssv > 0) & - call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) - - if (IDs%id_speed > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & - 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) - enddo ; enddo - call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) - endif - - call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) - -end subroutine post_surface_diagnostics - - !> Offers the static fields in the ocean grid type !! for output via the diag_manager. subroutine write_static_fields(G, GV, tv, diag) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7a83db96ad..e5b1688060 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -25,7 +25,7 @@ module MOM_diagnostics !********+*********+*********+*********+*********+*********+*********+** use MOM_coms, only : reproducing_sum -use MOM_diag_mediator, only : post_data, post_data_1d_k +use MOM_diag_mediator, only : post_data, post_data_1d_k, get_diag_time_end use MOM_diag_mediator, only : register_diag_field, register_scalar_field use MOM_diag_mediator, only : diag_ctrl, time_type, safe_alloc_ptr use MOM_diag_mediator, only : diag_get_volume_cell_measure_dm_id @@ -38,11 +38,13 @@ module MOM_diagnostics use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta -use MOM_spatial_means, only : global_area_mean, global_layer_mean, global_volume_mean +use MOM_spatial_means, only : global_area_mean, global_layer_mean +use MOM_spatial_means, only : global_volume_mean, global_area_integral use MOM_variables, only : thermo_var_ptrs, ocean_internal_state, p3d -use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs +use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, surface use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use coupler_types_mod, only : coupler_type_send_data implicit none ; private @@ -51,9 +53,8 @@ module MOM_diagnostics public calculate_diagnostic_fields public register_time_deriv public find_eta -public MOM_diagnostics_init -public MOM_diagnostics_end - +public MOM_diagnostics_init, MOM_diagnostics_end +public register_surface_diags, post_surface_diagnostics type, public :: diagnostics_CS ; private real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as @@ -151,6 +152,33 @@ module MOM_diagnostics end type diagnostics_CS + +!> A structure with diagnostic IDs of the surface and integrated variables +type, public :: surface_diag_IDs ; private + ! 2-d surface and bottom fields + integer :: id_zos = -1 + integer :: id_zossq = -1 + integer :: id_volo = -1 + integer :: id_ssh = -1 + integer :: id_ssh_ga = -1 + integer :: id_sst = -1 + integer :: id_sst_sq = -1 + integer :: id_sss = -1 + integer :: id_sss_sq = -1 + integer :: id_ssu = -1 + integer :: id_ssv = -1 + integer :: id_speed = -1 + integer :: id_sstcon = -1 + integer :: id_sssabs = -1 + + ! heat and salt flux fields + integer :: id_fraz = -1 + integer :: id_salt_deficit = -1 + integer :: id_Heat_PmE = -1 + integer :: id_intern_heat = -1 +end type surface_diag_IDs + + contains !> Diagnostics not more naturally calculated elsewhere are computed here. subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & @@ -1114,6 +1142,167 @@ subroutine calculate_derivs(dt, G, CS) end subroutine calculate_derivs +!> This routine posts diagnostics of various ocean surface and integrated +!! quantities at the time the ocean state is reported back to the caller +subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, ssh, fluxes) + type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + real, intent(in) :: dt_int !< total time step associated with these diagnostics, in s. + type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ssh !< Time mean surface height without + !! corrections for ice displacement(m) + type(forcing), intent(in) :: fluxes !< pointers to forcing fields + + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + real, dimension(SZI_(G),SZJ_(G)) :: & + zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh (meter) + real :: I_time_int ! The inverse of the time interval in s-1. + real :: zos_area_mean, volo, ssh_ga + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! area mean SSH + if (IDs%id_ssh_ga > 0) then + ssh_ga = global_area_mean(ssh, G) + call post_data(IDs%id_ssh_ga, ssh_ga, diag) + endif + + I_time_int = 1.0 / dt_int + if (IDs%id_ssh > 0) & + call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) + + ! post the dynamic sea level, zos, and zossq. + ! zos is ave_ssh with sea ice inverse barometer removed, + ! and with zero global area mean. + if (IDs%id_zos > 0 .or. IDs%id_zossq > 0) then + zos(:,:) = 0.0 + do j=js,je ; do i=is,ie + zos(i,j) = ssh(i,j) + enddo ; enddo + if (ASSOCIATED(fluxes%p_surf)) then + do j=js,je ; do i=is,ie + zos(i,j) = zos(i,j) + G%mask2dT(i,j)*fluxes%p_surf(i,j) / & + (GV%Rho0 * GV%g_Earth) + enddo ; enddo + endif + zos_area_mean = global_area_mean(zos, G) + do j=js,je ; do i=is,ie + zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean + enddo ; enddo + if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) + if (IDs%id_zossq > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = zos(i,j)*zos(i,j) + enddo ; enddo + call post_data(IDs%id_zossq, work_2d, diag, mask=G%mask2dT) + endif + endif + + ! post total volume of the liquid ocean + if (IDs%id_volo > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = G%mask2dT(i,j)*(ssh(i,j) + G%bathyT(i,j)) + enddo ; enddo + volo = global_area_integral(work_2d, G) + call post_data(IDs%id_volo, volo, diag) + endif + + ! post time-averaged rate of frazil formation + if (ASSOCIATED(tv%frazil) .and. (IDs%id_fraz > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%frazil(i,j) * I_time_int + enddo ; enddo + call post_data(IDs%id_fraz, work_2d, diag, mask=G%mask2dT) + endif + + ! post time-averaged salt deficit + if (ASSOCIATED(tv%salt_deficit) .and. (IDs%id_salt_deficit > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int + enddo ; enddo + call post_data(IDs%id_salt_deficit, work_2d, diag, mask=G%mask2dT) + endif + + ! post temperature of P-E+R + if (ASSOCIATED(tv%TempxPmE) .and. (IDs%id_Heat_PmE > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) + enddo ; enddo + call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) + endif + + ! post geothermal heating or internal heat source/sinks + if (ASSOCIATED(tv%internal_heat) .and. (IDs%id_intern_heat > 0)) then + do j=js,je ; do i=is,ie + work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) + enddo ; enddo + call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) + endif + + if (tv%T_is_conT) then + ! Internal T&S variables are conservative temperature & absolute salinity + if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) + ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp + ! to potential temperature. + do j=js,je ; do i=is,ie + work_2d(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j),sfc_state%SST(i,j)) + enddo ; enddo + if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag, mask=G%mask2dT) + else + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) + endif + + if (tv%S_is_absS) then + ! Internal T&S variables are conservative temperature & absolute salinity + if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) + ! Use TEOS-10 function calls convert T&S diagnostics from absolute salinity + ! to practical salinity. + do j=js,je ; do i=is,ie + work_2d(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) + enddo ; enddo + if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag, mask=G%mask2dT) + else + ! Internal T&S variables are potential temperature & practical salinity + if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) + endif + + if (IDs%id_sst_sq > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j) + enddo ; enddo + call post_data(IDs%id_sst_sq, work_2d, diag, mask=G%mask2dT) + endif + if (IDs%id_sss_sq > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j) + enddo ; enddo + call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) + endif + + if (IDs%id_ssu > 0) & + call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) + if (IDs%id_ssv > 0) & + call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) + + if (IDs%id_speed > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & + 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) + enddo ; enddo + call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) + endif + + call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) + +end subroutine post_surface_diagnostics + + !> This subroutine registers various diagnostics and allocates space for fields !! that other diagnostis depend upon. subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS, tv) @@ -1414,6 +1603,81 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS end subroutine MOM_diagnostics_init + +!> Register diagnostics of the surface state and integrated quantities +subroutine register_surface_diags(Time, G, IDs, diag, missing, tv) + type(time_type), intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(surface_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + real, intent(in) :: missing !< The value to use to fill in missing data + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + ! Vertically integrated, budget, and surface state diagnostics + IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& + long_name='Total volume of liquid ocean', units='m3', & + standard_name='sea_water_volume') + IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& + standard_name = 'sea_surface_height_above_geoid', & + long_name= 'Sea surface height above geoid', units='m', missing_value=missing) + IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& + standard_name='square_of_sea_surface_height_above_geoid', & + long_name='Square of sea surface height above geoid', units='m2', missing_value=missing) + IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & + 'Sea Surface Height', 'm', missing) + IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& + long_name='Area averaged sea surface height', units='m', & + standard_name='area_averaged_sea_surface_height') + IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & + 'Sea Surface Zonal Velocity', 'm s-1', missing) + IDs%id_ssv = register_diag_field('ocean_model', 'SSV', diag%axesCv1, Time, & + 'Sea Surface Meridional Velocity', 'm s-1', missing) + IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & + 'Sea Surface Speed', 'm s-1', missing) + + if (associated(tv%T)) then + IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & + 'Sea Surface Temperature', 'degC', missing, cmor_field_name='tos', & + cmor_long_name='Sea Surface Temperature', & + cmor_standard_name='sea_surface_temperature') + IDs%id_sst_sq = register_diag_field('ocean_model', 'SST_sq', diag%axesT1, Time, & + 'Sea Surface Temperature Squared', 'degC2', missing, cmor_field_name='tossq', & + cmor_long_name='Square of Sea Surface Temperature ', & + cmor_standard_name='square_of_sea_surface_temperature') + IDs%id_sss = register_diag_field('ocean_model', 'SSS', diag%axesT1, Time, & + 'Sea Surface Salinity', 'psu', missing, cmor_field_name='sos', & + cmor_long_name='Sea Surface Salinity', & + cmor_standard_name='sea_surface_salinity') + IDs%id_sss_sq = register_diag_field('ocean_model', 'SSS_sq', diag%axesT1, Time, & + 'Sea Surface Salinity Squared', 'psu', missing, cmor_field_name='sossq', & + cmor_long_name='Square of Sea Surface Salinity ', & + cmor_standard_name='square_of_sea_surface_salinity') + if (tv%T_is_conT) then + IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & + 'Sea Surface Conservative Temperature', 'Celsius', missing) + endif + if (tv%S_is_absS) then + IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & + 'Sea Surface Absolute Salinity', 'g kg-1', missing) + endif + if (ASSOCIATED(tv%frazil)) then + IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & + 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & + cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & + cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') + endif + endif + + IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & + 'Salt sink in ocean due to ice flux', 'psu m-2 s-1') + IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & + 'Heat flux into ocean from mass flux into ocean', 'W m-2') + IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& + 'Heat flux into ocean from geothermal or other internal sources', 'W m-2') + +end subroutine register_surface_diags + + !> This subroutine sets up diagnostics upon which other diagnostics depend. subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) type(ocean_internal_state), intent(in) :: MIS !< For "MOM Internal State" a set of pointers to From 9800b26067522e9ec558284ae29b102fc15dc472 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jan 2018 22:14:48 -0500 Subject: [PATCH 146/170] +Separated transport and state diagnostics Separated register_transport_diags out of register_diags and split the MOM_diag_IDs into MOM_diag_IDs and transport_diag_IDs. All answers are bitwise identical. --- src/core/MOM.F90 | 39 ++++++++++++++++++++++++++++++++------- 1 file changed, 32 insertions(+), 7 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 178ddbc1d4..49e694b320 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -153,11 +153,14 @@ module MOM integer :: id_u = -1, id_v = -1, id_h = -1 ! 2-d state field integer :: id_ssh_inst = -1 +end type MOM_diag_IDs +!> A structure with diagnostic IDs of mass transport related diagnostics +type transport_diag_IDs ! Diagnostics for tracer horizontal transport integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = -1 integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 -end type MOM_diag_IDs +end type transport_diag_IDs !> Control structure for this module type, public :: MOM_control_struct @@ -291,6 +294,7 @@ module MOM logical :: tendency_diagnostics = .false. type(MOM_diag_IDs) :: IDs + type(transport_diag_IDs) :: transport_IDs type(surface_diag_IDs) :: sfc_IDs ! The remainder provides pointers to child module control structures. @@ -688,7 +692,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif ! Store pre-dynamics state for proper diagnostic remapping if mass transports requested - if (transport_remap_grid_needed(IDs)) then + if (transport_remap_grid_needed(CS%transport_IDs)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied h_pre_dyn(i,j,k) = h(i,j,k) if (associated(CS%tv%T)) T_pre_dyn(i,j,k) = CS%tv%T(i,j,k) @@ -958,8 +962,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) - call post_transport_diagnostics(G, GV, CS%uhtr, CS%vhtr, h, CS%IDs, CS%diag, CS%t_dyn_rel_adv, & - CS%diag_to_Z_CSp, h_pre_dyn, T_pre_dyn, S_pre_dyn) + call post_transport_diagnostics(G, GV, CS%uhtr, CS%vhtr, h, CS%transport_IDs, & + CS%diag, CS%t_dyn_rel_adv, CS%diag_to_Z_CSp, h_pre_dyn, T_pre_dyn, S_pre_dyn) ! Rebuild the remap grids now that we've posted the fields which rely on thicknesses ! from before the dynamics calls call diag_update_remap_grids(CS%diag) @@ -2148,6 +2152,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! now register some diagnostics since the tracer registry is now locked call register_surface_diags(Time, G, CS%sfc_IDs, CS%diag, CS%missing, CS%tv) call register_diags(Time, G, GV, CS%IDs, CS%diag, CS%missing) + call register_transport_diags(Time, G, GV, CS%transport_IDs, CS%diag, CS%missing) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & CS%use_ALE_algorithm, CS%diag_to_Z_CSp) if (CS%use_ALE_algorithm) then @@ -2296,6 +2301,26 @@ subroutine register_diags(Time, G, GV, IDs, diag, missing) 'Layer Thickness', thickness_units, v_extensive=.true., conversion=H_convert) IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, Time, & 'Instantaneous Sea Surface Height', 'm', missing) +end subroutine register_diags + +!> Register certain diagnostics related to transports +subroutine register_transport_diags(Time, G, GV, IDs, diag, missing) + type(time_type), intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(transport_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. + type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output + real, intent(in) :: missing !< The value to use to fill in missing data + + real :: H_convert + character(len=48) :: thickness_units + + thickness_units = get_thickness_units(GV) + if (GV%Boussinesq) then + H_convert = GV%H_to_m + else + H_convert = GV%H_to_kg_m2 + endif ! Diagnostics related to tracer and mass transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & @@ -2317,7 +2342,7 @@ subroutine register_diags(Time, G, GV, IDs, diag, missing) diag%axesCv1, Time, 'Ocean Mass Y Transport Vertical Sum', 'kg s-1', & standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') -end subroutine register_diags +end subroutine register_transport_diags !> This subroutine sets up clock IDs for timing various subroutines. subroutine MOM_timing_init(CS) @@ -2363,7 +2388,7 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag, dt_trans, !! used to advect tracers (m3 or kg) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< The updated layer thicknesses, in H - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(transport_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output real, intent(in) :: dt_trans !< total time step associated with the transports, in s. type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A control structure for remapping @@ -2430,7 +2455,7 @@ end subroutine post_transport_diagnostics !> Indicate whether it is necessary to save and recalculate the grid for finding !! remapped transports. function transport_remap_grid_needed(IDs) result(needed) - type(MOM_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs + type(transport_diag_IDs), intent(in) :: IDs !< A structure with transport-related diagnostic IDs logical :: needed needed = .false. From 3cd24bc41797c54198ddfe1f4b8c4dbf794e3321 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Jan 2018 17:55:51 -0500 Subject: [PATCH 147/170] +Created a MOM_state_type Created a new MOM_state_type and separated it from the MOM_control_structure, including adding new parallel arguments to many of the routines in MOM.F90. This change also required changes to the various coupled and ocean-only MOM drivers to reflect elements of these public types that had moved. All answers are bitwise identical. --- config_src/coupled_driver/ocean_model_MOM.F90 | 154 +++--- config_src/mct_driver/ocn_comp_mct.F90 | 39 +- config_src/solo_driver/MOM_driver.F90 | 35 +- src/core/MOM.F90 | 487 +++++++++--------- 4 files changed, 374 insertions(+), 341 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 756c648120..6e28d30d9f 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -17,7 +17,7 @@ module ocean_model_mod ! in the same way as MOM4. ! -use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_state_type, MOM_end use MOM, only : calculate_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : step_offline use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf @@ -140,29 +140,29 @@ module ocean_model_mod type, public :: ocean_state_type ; private ! This type is private, and can therefore vary between different ocean models. logical :: is_ocean_PE = .false. !< True if this is an ocean PE. - type(time_type) :: Time ! The ocean model's time and master clock. - integer :: Restart_control ! An integer that is bit-tested to determine whether - ! incremental restart files are saved and whether they - ! have a time stamped name. +1 (bit 0) for generic - ! files and +2 (bit 1) for time-stamped files. A - ! restart file is saved at the end of a run segment - ! unless Restart_control is negative. - - type(time_type) :: energysavedays ! The interval between writing the energies - ! and other integral quantities of the run. - type(time_type) :: energysavedays_geometric ! The starting interval for computing a geometric - ! progression of time deltas between calls to - ! write_energy. This interval will increase by a factor of 2. - ! after each call to write_energy. - logical :: energysave_geometric ! Logical to control whether calls to write_energy should - ! follow a geometric progression - type(time_type) :: write_energy_time ! The next time to write to the energy file. - type(time_type) :: geometric_end_time ! Time at which to stop the geometric progression - ! of calls to write_energy and revert to the standard - ! energysavedays interval - - integer :: nstep = 0 ! The number of calls to update_ocean. - logical :: use_ice_shelf ! If true, the ice shelf model is enabled. + type(time_type) :: Time !< The ocean model's time and master clock. + integer :: Restart_control !< An integer that is bit-tested to determine whether + !! incremental restart files are saved and whether they + !! have a time stamped name. +1 (bit 0) for generic + !! files and +2 (bit 1) for time-stamped files. A + !! restart file is saved at the end of a run segment + !! unless Restart_control is negative. + + type(time_type) :: energysavedays !< The interval between writing the energies + !! and other integral quantities of the run. + type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric + !! progression of time deltas between calls to + !! write_energy. This interval will increase by a factor of 2. + !! after each call to write_energy. + logical :: energysave_geometric !< Logical to control whether calls to write_energy should + !! follow a geometric progression + type(time_type) :: write_energy_time !< The next time to write to the energy file. + type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression + !! of calls to write_energy and revert to the standard + !! energysavedays interval + + integer :: nstep = 0 !< The number of calls to update_ocean. + logical :: use_ice_shelf !< If true, the ice shelf model is enabled. ! Many of the following variables do not appear to belong here. -RWH logical :: icebergs_apply_rigid_boundary ! If true, the icebergs can change ocean bd condition. @@ -173,31 +173,41 @@ module ocean_model_mod real :: latent_heat_fusion ! Latent heat of fusion real :: density_iceberg ! A typical density of icebergs in kg/m3 (for ice rigidity) - type(ice_shelf_CS), pointer :: Ice_shelf_CSp => NULL() - logical :: restore_salinity ! If true, the coupled MOM driver adds a term to - ! restore salinity to a specified value. - logical :: restore_temp ! If true, the coupled MOM driver adds a term to - ! restore sst to a specified value. - real :: press_to_z ! A conversion factor between pressure and ocean - ! depth in m, usually 1/(rho_0*g), in m Pa-1. - real :: C_p ! The heat capacity of seawater, in J K-1 kg-1. + logical :: restore_salinity !< If true, the coupled MOM driver adds a term to + !! restore salinity to a specified value. + logical :: restore_temp !< If true, the coupled MOM driver adds a term to + !! restore sst to a specified value. + real :: press_to_z !< A conversion factor between pressure and ocean + !! depth in m, usually 1/(rho_0*g), in m Pa-1. + real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. - type(directories) :: dirs ! A structure containing several relevant directory paths. + type(directories) :: dirs !< A structure containing several relevant directory paths. type(mech_forcing) :: forces !< A structure with the driving mechanical surface forces - type(forcing) :: fluxes ! A structure containing pointers to - ! the thermodynamic ocean forcing fields. - type(forcing) :: flux_tmp ! A secondary structure containing pointers to the - ! ocean forcing fields for when multiple coupled - ! timesteps are taken per thermodynamic step. - type(surface) :: sfc_state ! A structure containing pointers to - ! the ocean surface state fields. - type(ocean_grid_type), pointer :: grid => NULL() ! A pointer to a grid structure - ! containing metrics and related information. - type(verticalGrid_type), pointer :: GV => NULL() ! A pointer to a vertical grid - ! structure containing metrics and related information. - type(MOM_control_struct), pointer :: MOM_CSp => NULL() - type(surface_forcing_CS), pointer :: forcing_CSp => NULL() - type(sum_output_CS), pointer :: sum_output_CSp => NULL() + type(forcing) :: fluxes !< A structure containing pointers to + !! the thermodynamic ocean forcing fields. + type(forcing) :: flux_tmp !< A secondary structure containing pointers to the + !! ocean forcing fields for when multiple coupled + !! timesteps are taken per thermodynamic step. + type(surface) :: sfc_state !< A structure containing pointers to + !! the ocean surface state fields. + type(ocean_grid_type), pointer :: & + grid => NULL() !< A pointer to a grid structure containing metrics + !! and related information. + type(verticalGrid_type), pointer :: & + GV => NULL() !< A pointer to a structure containing information + !! about the vertical grid. + type(MOM_control_struct), pointer :: & + MOM_CSp => NULL() !< A pointer to the MOM control structure + type(MOM_state_type), pointer :: & + MSp => NULL() !< A pointer to the MOM_state_type + type(ice_shelf_CS), pointer :: & + Ice_shelf_CSp => NULL() !< A pointer to the control structure for the + !! ice shelf model that couples with MOM6. This + !! is null if there is no ice shelf. + type(surface_forcing_CS), pointer :: & + forcing_CSp => NULL() !< A pointer to the MOM forcing control structure + type(sum_output_CS), pointer :: & + sum_output_CSp => NULL() !< A pointer to the MOM sum output control structure end type ocean_state_type contains @@ -263,11 +273,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) if (.not.OS%is_ocean_pe) return OS%Time = Time_in - call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MOM_CSp, Time_in, & + call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, Time_in, & offline_tracer_mode=offline_tracer_mode) - OS%grid => OS%MOM_CSp%G ; OS%GV => OS%MOM_CSp%GV - OS%C_p = OS%MOM_CSp%tv%C_p - OS%fluxes%C_p = OS%MOM_CSp%tv%C_p + OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV + OS%C_p = OS%MSp%tv%C_p + OS%fluxes%C_p = OS%MSp%tv%C_p ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -371,7 +381,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%MOM_CSp%ntrunc, Time_init, OS%sum_output_CSp) ! This call has been moved into the first call to update_ocean_model. - ! call write_energy(OS%MOM_CSp%u, OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%tv, & + ! call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & ! OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, OS%MOM_CSp%tracer_flow_CSp) ! write_energy_time is the next integral multiple of energysavedays. @@ -404,9 +414,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call coupler_type_set_diags(Ocean_sfc%fields, "ocean_sfc", & Ocean_sfc%axes(1:2), Time_in) - call calculate_surface_state(OS%sfc_state, OS%MOM_CSp%u, & - OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& - OS%grid, OS%GV, OS%MOM_CSp) + call calculate_surface_state(OS%sfc_state, OS%MSp%u, & + OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%grid, OS%GV, OS%MSp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) @@ -560,9 +570,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%fluxes) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes) - call write_energy(OS%MOM_CSp%u, OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%tv, & + call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) endif @@ -571,9 +581,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Master_time = OS%Time ; Time1 = OS%Time if(OS%MOM_Csp%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MSp, OS%MOM_CSp) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MSp, OS%MOM_CSp) endif OS%Time = Master_time + Ocean_coupling_time_step @@ -598,7 +608,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%energysave_geometric) then if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%geometric_end_time) .and. & (OS%MOM_CSp%t_dyn_rel_adv==0.0)) then - call write_energy(OS%MOM_CSp%u, OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%tv, & + call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) OS%write_energy_time = OS%geometric_end_time + OS%energysavedays @@ -608,7 +618,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%write_energy_time) .and. & (OS%MOM_CSp%t_dyn_rel_adv==0.0)) then - call write_energy(OS%MOM_CSp%u, OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%tv, & + call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) if (OS%energysave_geometric) then @@ -803,7 +813,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%MOM_CSp%diag) - call MOM_end(Ocean_state%MOM_CSp) + call MOM_end(Ocean_state%MSp, Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) end subroutine ocean_model_end ! NAME="ocean_model_end" @@ -1029,9 +1039,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - call calculate_surface_state(OS%sfc_state, OS%MOM_CSp%u, & - OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& - OS%grid, OS%GV, OS%MOM_CSp) + call calculate_surface_state(OS%sfc_state, OS%MSp%u, & + OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%grid, OS%GV, OS%MSp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) @@ -1094,30 +1104,30 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) to_mass = OS%GV%H_to_kg_m2 if (OS%GV%Boussinesq) then do k=1,nz ; do j=js,je ; do i=is,ie ; if (OS%grid%mask2dT(i,j) > 0.5) then - value = value + to_mass*(OS%MOM_CSp%h(i,j,k) * OS%grid%areaT(i,j)) + value = value + to_mass*(OS%MSp%h(i,j,k) * OS%grid%areaT(i,j)) endif ; enddo ; enddo ; enddo else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. PSU_to_kg = 1.0e-3 do k=1,nz ; do j=js,je ; do i=is,ie ; if (OS%grid%mask2dT(i,j) > 0.5) then - value = value + to_mass * ((1.0 - PSU_to_kg*OS%MOM_CSp%tv%S(i,j,k))*& - (OS%MOM_CSp%h(i,j,k) * OS%grid%areaT(i,j))) + value = value + to_mass * ((1.0 - PSU_to_kg*OS%MSp%tv%S(i,j,k))*& + (OS%MSp%h(i,j,k) * OS%grid%areaT(i,j))) endif ; enddo ; enddo ; enddo endif case (ISTOCK_HEAT) ! Return the heat content of the ocean on this PE in J. to_heat = OS%GV%H_to_kg_m2 * OS%C_p do k=1,nz ; do j=js,je ; do i=is,ie ; if (OS%grid%mask2dT(i,j) > 0.5) then - value = value + (to_heat * OS%MOM_CSp%tv%T(i,j,k)) * & - (OS%MOM_CSp%h(i,j,k)*OS%grid%areaT(i,j)) + value = value + (to_heat * OS%MSp%tv%T(i,j,k)) * & + (OS%MSp%h(i,j,k)*OS%grid%areaT(i,j)) endif ; enddo ; enddo ; enddo case (ISTOCK_SALT) ! Return the mass of the salt in the ocean on this PE in kg. ! The 1000 converts salinity in PSU to salt in kg kg-1. to_salt = OS%GV%H_to_kg_m2 / 1000.0 do k=1,nz ; do j=js,je ; do i=is,ie ; if (OS%grid%mask2dT(i,j) > 0.5) then - value = value + (to_salt * OS%MOM_CSp%tv%S(i,j,k)) * & - (OS%MOM_CSp%h(i,j,k)*OS%grid%areaT(i,j)) + value = value + (to_salt * OS%MSp%tv%S(i,j,k)) * & + (OS%MSp%h(i,j,k)*OS%grid%areaT(i,j)) endif ; enddo ; enddo ; enddo case default ; value = 0.0 end select diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 5413164a99..624b0c36e8 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -32,7 +32,7 @@ module ocn_comp_mct use MOM_coms, only : reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM, only: initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only: initialize_MOM, step_MOM, MOM_control_struct, MOM_state_type, MOM_end use MOM, only: calculate_surface_state, allocate_surface_state use MOM, only: finish_MOM_initialization, step_offline use MOM_forcing_type, only: forcing, forcing_diags, register_forcing_type_diags @@ -330,6 +330,7 @@ module ocn_comp_mct type(verticalGrid_type), pointer :: GV => NULL() !< A pointer to a vertical grid !! structure containing metrics and related information. type(MOM_control_struct), pointer :: MOM_CSp => NULL() + type(MOM_state_type), pointer :: MSp => NULL() type(surface_forcing_CS), pointer :: forcing_CSp => NULL() type(sum_output_CS), pointer :: sum_output_CSp => NULL() end type ocean_state_type @@ -825,11 +826,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (.not.OS%is_ocean_pe) return OS%Time = Time_in - call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MOM_CSp, Time_in, & + call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, Time_in, & offline_tracer_mode=offline_tracer_mode, input_restart_file=input_restart_file) - OS%grid => OS%MOM_CSp%G ; OS%GV => OS%MOM_CSp%GV - OS%C_p = OS%MOM_CSp%tv%C_p - OS%fluxes%C_p = OS%MOM_CSp%tv%C_p + OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV + OS%C_p = OS%MSp%tv%C_p + OS%fluxes%C_p = OS%MSp%tv%C_p ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -919,7 +920,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%MOM_CSp%ntrunc, Time_init, OS%sum_output_CSp) ! This call has been moved into the first call to update_ocean_model. -! call write_energy(OS%MOM_CSp%u, OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%tv, & +! call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & ! OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, OS%MOM_CSp%tracer_flow_CSp) ! write_energy_time is the next integral multiple of energysavedays. @@ -938,9 +939,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! This call can only occur here if the coupler_bc_type variables have been ! initialized already using the information from gas_fields_ocn. if (present(gas_fields_ocn)) then - call calculate_surface_state(OS%state, OS%MOM_CSp%u, & - OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& - OS%grid, OS%GV, OS%MOM_CSp) + call calculate_surface_state(OS%state, OS%MSp%u, & + OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%grid, OS%GV, OS%MSp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid) endif @@ -968,9 +969,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call coupler_type_spawn(Ocean_sfc%fields, OS%state%tr_fields, & (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - call calculate_surface_state(OS%state, OS%MOM_CSp%u, & - OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%ave_ssh,& - OS%grid, OS%GV, OS%MOM_CSp) + call calculate_surface_state(OS%state, OS%MSp%u, & + OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%grid, OS%GV, OS%Msp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid) @@ -1621,7 +1622,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%MOM_CSp%restart_CSp, .false., filename=restartname,GV=glb%ocn_state%GV) + glb%ocn_state%MOM_CSp%restart_CSp, .false., filename=restartname,GV=glb%ocn_state%GV) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -1776,9 +1777,9 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%fluxes) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes) - call write_energy(OS%MOM_CSp%u, OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%tv, & + call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) endif @@ -1787,9 +1788,9 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & Master_time = OS%Time ; Time1 = OS%Time if(OS%MOM_Csp%offline_tracer_mode) then - call step_offline(OS%fluxes, OS%state, Time1, time_step, OS%MOM_CSp) + call step_offline(OS%fluxes, OS%state, Time1, time_step, OS%MSp, OS%MOM_CSp) else - call step_MOM(OS%fluxes, OS%state, Time1, time_step, OS%MOM_CSp) + call step_MOM(OS%fluxes, OS%state, Time1, time_step, OS%MSp, OS%MOM_CSp) endif OS%Time = Master_time + Ocean_coupling_time_step @@ -1812,7 +1813,7 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & ! See if it is time to write out the energy. if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%write_energy_time) .and. & (OS%MOM_CSp%t_dyn_rel_adv==0.0)) then - call write_energy(OS%MOM_CSp%u, OS%MOM_CSp%v, OS%MOM_CSp%h, OS%MOM_CSp%tv, & + call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) OS%write_energy_time = OS%write_energy_time + OS%energysavedays @@ -2454,7 +2455,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) !if (debug .and. is_root_pe()) write(glb%stdout,*)'Here 1' !GMM call save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%MOM_CSp%diag) - call MOM_end(Ocean_state%MOM_CSp) + call MOM_end(Ocean_state%MSp, Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) !if (debug .and. is_root_pe()) write(glb%stdout,*)'Here 2' diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 5e727ed250..f1faa40cd4 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -30,7 +30,7 @@ program MOM_main use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : calculate_surface_state, finish_MOM_initialization - use MOM, only : step_offline + use MOM, only : MOM_state_type, step_offline use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -169,6 +169,7 @@ program MOM_main ! a previous integration of the prognostic model type(MOM_control_struct), pointer :: MOM_CSp => NULL() + type(MOM_state_type), pointer :: MSp => NULL() type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() @@ -279,20 +280,20 @@ program MOM_main segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time ! Note the not before CS%d - call initialize_MOM(Time, param_file, dirs, MOM_CSp, segment_start_time, offline_tracer_mode = offline_tracer_mode) + call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, segment_start_time, offline_tracer_mode = offline_tracer_mode) else ! In this case, the segment starts at a time read from the MOM restart file ! or left as Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, param_file, dirs, MOM_CSp, offline_tracer_mode=offline_tracer_mode) + call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, offline_tracer_mode=offline_tracer_mode) endif - fluxes%C_p = MOM_CSp%tv%C_p ! Copy the heat capacity for consistency. + fluxes%C_p = MSp%tv%C_p ! Copy the heat capacity for consistency. Master_Time = Time - grid => MOM_CSp%G - GV => MOM_CSp%GV - call calculate_surface_state(sfc_state, MOM_CSp%u, MOM_CSp%v, MOM_CSp%h, & - MOM_CSp%ave_ssh, grid, GV, MOM_CSp) + grid => MSp%G + GV => MSp%GV + call calculate_surface_state(sfc_state, MSp%u, MSp%v, MSp%h, & + MOM_CSp%ave_ssh, grid, GV, MSp, MOM_CSp) call surface_forcing_init(Time, grid, param_file, MOM_CSp%diag, & @@ -400,8 +401,8 @@ program MOM_main endif ! This has been moved inside the loop to be applied when n=1. -! call write_energy(MOM_CSp%u, MOM_CSp%v, MOM_CSp%h, & -! MOM_CSp%tv, Time, 0, grid, GV, sum_output_CSp, MOM_CSp%tracer_flow_CSp) +! call write_energy(MSp%u, MSp%v, MSp%h, & +! MSp%tv, Time, 0, grid, GV, sum_output_CSp, MOM_CSp%tracer_flow_CSp) call write_cputime(Time, 0, nmax, write_CPU_CSp) write_energy_time = Start_time + energysavedays * & @@ -448,9 +449,9 @@ program MOM_main fluxes%dt_buoy_accum = time_step if (n==1) then - call finish_MOM_initialization(Time, dirs, MOM_CSp, fluxes) + call finish_MOM_initialization(Time, dirs, MSp, MOM_CSp, fluxes) - call write_energy(MOM_CSp%u, MOM_CSp%v, MOM_CSp%h, MOM_CSp%tv, & + call write_energy(MSp%u, MSp%v, MSp%h, MSp%tv, & Time, 0, grid, GV, sum_output_CSp, MOM_CSp%tracer_flow_CSp, & MOM_CSp%OBC) endif @@ -458,9 +459,9 @@ program MOM_main ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time if (offline_tracer_mode) then - call step_offline(forces, fluxes, sfc_state, Time1, time_step, MOM_CSp) + call step_offline(forces, fluxes, sfc_state, Time1, time_step, MSp, MOM_CSp) else - call step_MOM(forces, fluxes, sfc_state, Time1, time_step, MOM_CSp) + call step_MOM(forces, fluxes, sfc_state, Time1, time_step, MSp, MOM_CSp) endif ! Time = Time + Time_step_ocean @@ -504,8 +505,8 @@ program MOM_main ! See if it is time to write out the energy. if ((Time + (Time_step_ocean/2) > write_energy_time) .and. & (MOM_CSp%t_dyn_rel_adv == 0.0)) then - call write_energy(MOM_CSp%u, MOM_CSp%v, MOM_CSp%h, & - MOM_CSp%tv, Time, n+ntstep-1, grid, GV, sum_output_CSp, & + call write_energy(MSp%u, MSp%v, MSp%h, & + MSp%tv, Time, n+ntstep-1, grid, GV, sum_output_CSp, & MOM_CSp%tracer_flow_CSp) call write_cputime(Time, n+ntstep-1, nmax, write_CPU_CSp) write_energy_time = write_energy_time + energysavedays @@ -587,7 +588,7 @@ program MOM_main call io_infra_end ; call MOM_infra_end - call MOM_end(MOM_CSp) + call MOM_end(MSp, MOM_CSp) if (use_ice_shelf) call ice_shelf_end(ice_shelf_CSp) end program MOM_main diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 49e694b320..a8202877df 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -162,8 +162,8 @@ module MOM integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 end type transport_diag_IDs -!> Control structure for this module -type, public :: MOM_control_struct +!> Structure describing the state of the ocean. +type, public :: MOM_state_type real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: & h, & !< layer thickness (m or kg/m2 (H)) T, & !< potential temperature (degrees C) @@ -176,17 +176,16 @@ module MOM v, & !< meridional velocity (m/s) vh, & !< vh = v * h * dx at v grid points (m3/s or kg/s) vhtr !< accumulated meridional thickness fluxes to advect tracers (m3 or kg) - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - ave_ssh !< time-averaged (ave over baroclinic time steps) sea surface height (meter) - real, pointer, dimension(:,:) :: Hml => NULL() !< active mixed layer depth, in m - real, pointer, dimension(:,:,:) :: & - u_prev => NULL(), & !< previous value of u stored for diagnostics - v_prev => NULL() !< previous value of v stored for diagnostics type(ocean_grid_type) :: G !< structure containing metrics and grid info type(verticalGrid_type), pointer :: GV => NULL() !< structure containing vertical grid info type(thermo_var_ptrs) :: tv !< structure containing pointers to available !! thermodynamic fields +end type MOM_state_type + + +!> Control structure for this module +type, public :: MOM_control_struct type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing type(vertvisc_type) :: visc !< structure containing vertical viscosities, !! bottom drag viscosities, and related fields @@ -196,6 +195,12 @@ module MOM !! for derived diagnostics (e.g., energy budgets) type(cont_diag_ptrs) :: CDp !< structure containing pointers continuity equation !! terms, for derived diagnostics (e.g., energy budgets) + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + ave_ssh !< time-averaged (ave over baroclinic time steps) sea surface height (meter) + real, pointer, dimension(:,:) :: Hml => NULL() !< active mixed layer depth, in m + real, pointer, dimension(:,:,:) :: & + u_prev => NULL(), & !< previous value of u stored for diagnostics + v_prev => NULL() !< previous value of v stored for diagnostics logical :: split !< If true, use the split time stepping scheme. logical :: use_RK2 !< If true, use RK2 instead of RK3 in unsplit mode @@ -368,12 +373,13 @@ module MOM !! The action of lateral processes on tracers occur in calls to !! advect_tracer and tracer_hordiff. Vertical mixing and possibly remapping !! occur inside of diabatic. -subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) +subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(surface), intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_interval !< time interval covered by this run segment, in s. + type(MOM_state_type), pointer :: MS !< structure describing the MOM state type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM ! local @@ -411,7 +417,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) logical :: do_calc_bbl ! If true, calculate the boundary layer properties. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans ! multiple dynamic timesteps. - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & + real, dimension(SZI_(MS%G),SZJ_(MS%G)) :: & eta_av, & ! average sea surface height or column mass over a timestep (meter or kg/m2) ssh ! sea surface height based on eta_av (meter or kg/m2) @@ -422,9 +428,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! Store the layer thicknesses, temperature, and salinity before any changes by the dynamics. ! This is necessary for remapped mass transport diagnostics - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: h_pre_dyn - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: T_pre_dyn - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: S_pre_dyn + real, dimension(SZI_(MS%G),SZJ_(MS%G),SZK_(MS%G)) :: h_pre_dyn + real, dimension(SZI_(MS%G),SZJ_(MS%G),SZK_(MS%G)) :: T_pre_dyn + real, dimension(SZI_(MS%G),SZJ_(MS%G),SZK_(MS%G)) :: S_pre_dyn real :: tot_wt_ssh, Itot_wt_ssh type(time_type) :: Time_local, end_time_thermo @@ -432,19 +438,19 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! These are used for group halo passes. logical :: do_pass_Ray, do_pass_kv_bbl_thick - G => CS%G ; GV => CS%GV ; IDs => CS%IDs + G => MS%G ; GV => MS%GV ; IDs => CS%IDs 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 isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - u => CS%u ; v => CS%v ; h => CS%h + u => MS%u ; v => MS%v ; h => MS%h call cpu_clock_begin(id_clock_ocean) call cpu_clock_begin(id_clock_other) if (CS%debug) then - call MOM_state_chksum("Beginning of step_MOM ", u, v, h, CS%uh, CS%vh, G, GV) - call hchksum(CS%h,"CS%h beginning of step_MOM",G%HI, scale=GV%H_to_m) + call MOM_state_chksum("Beginning of step_MOM ", u, v, h, MS%uh, MS%vh, G, GV) + call hchksum(MS%h,"MS%h beginning of step_MOM",G%HI, scale=GV%H_to_m) endif showCallTree = callTree_showQuery() @@ -507,15 +513,15 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) if (.not.CS%adiabatic .AND. CS%use_ALE_algorithm ) then if (CS%use_temperature) then - call create_group_pass(CS%pass_T_S_h, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) - call create_group_pass(CS%pass_T_S_h, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(CS%pass_T_S_h, MS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(CS%pass_T_S_h, MS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) endif call create_group_pass(CS%pass_T_S_h, h, G%Domain, To_All+Omit_Corners, halo=1) endif if ((CS%adiabatic .OR. CS%diabatic_first) .AND. CS%use_temperature) then - call create_group_pass(CS%pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) - call create_group_pass(CS%pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(CS%pass_T_S, MS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(CS%pass_T_S, MS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) endif !---------- End setup for group halo pass @@ -527,10 +533,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif call cpu_clock_end(id_clock_pass) - if (ASSOCIATED(CS%tv%frazil)) CS%tv%frazil(:,:) = 0.0 - if (ASSOCIATED(CS%tv%salt_deficit)) CS%tv%salt_deficit(:,:) = 0.0 - if (ASSOCIATED(CS%tv%TempxPmE)) CS%tv%TempxPmE(:,:) = 0.0 - if (ASSOCIATED(CS%tv%internal_heat)) CS%tv%internal_heat(:,:) = 0.0 + if (ASSOCIATED(MS%tv%frazil)) MS%tv%frazil(:,:) = 0.0 + if (ASSOCIATED(MS%tv%salt_deficit)) MS%tv%salt_deficit(:,:) = 0.0 + if (ASSOCIATED(MS%tv%TempxPmE)) MS%tv%TempxPmE(:,:) = 0.0 + if (ASSOCIATED(MS%tv%internal_heat)) MS%tv%internal_heat(:,:) = 0.0 CS%rel_time = 0.0 @@ -540,7 +546,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) if (associated(CS%VarMix)) then call enable_averaging(time_interval, Time_start+set_time(int(time_interval)), & CS%diag) - call calc_resoln_function(h, CS%tv, G, GV, CS%VarMix) + call calc_resoln_function(h, MS%tv, G, GV, CS%VarMix) call disable_averaging(CS%diag) endif @@ -561,7 +567,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif if (CS%debug) then - call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV) + call MOM_state_chksum("Before steps ", u, v, h, MS%uh, MS%vh, G, GV) call MOM_forcing_chksum("Before steps", fluxes, G, haloshift=0) call check_redundant("Before steps ", u, v, G) call check_redundant("Before steps ", forces%taux, forces%tauy, G) @@ -602,7 +608,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) end_time_thermo = Time_local + set_time(int(floor(dtdia-dt+0.5))) ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, end_time_thermo, .true.) + call step_MOM_thermo(MS, CS, G, GV, u, v, h, MS%tv, fluxes, dtdia, end_time_thermo, .true.) ! The diabatic processes are now ahead of the dynamics by dtdia. CS%t_dyn_rel_thermo = -dtdia @@ -626,8 +632,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call enable_averaging(dtth,Time_local+set_time(int(floor(dtth-dt+0.5))), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dtth, G, GV, & + call calc_slope_functions(h, MS%tv, dt, G, GV, CS%VarMix) + call thickness_diffuse(h, MS%uhtr, MS%vhtr, MS%tv, dtth, G, GV, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass) !###, halo=max(2,cont_stensil)) @@ -649,7 +655,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) bbl_time_int = max(dt, min(dt_therm - CS%t_dyn_rel_adv, dt*(1+n_max-n)) ) call enable_averaging(bbl_time_int, & Time_local+set_time(int(bbl_time_int-dt+0.5)), CS%diag) - call set_viscous_BBL(u, v, h, CS%tv, CS%visc, G, GV, CS%set_visc_CSp) + call set_viscous_BBL(u, v, h, MS%tv, CS%visc, G, GV, CS%set_visc_CSp) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_BBL_visc) if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM)") @@ -695,8 +701,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) if (transport_remap_grid_needed(CS%transport_IDs)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied h_pre_dyn(i,j,k) = h(i,j,k) - if (associated(CS%tv%T)) T_pre_dyn(i,j,k) = CS%tv%T(i,j,k) - if (associated(CS%tv%S)) S_pre_dyn(i,j,k) = CS%tv%S(i,j,k) + if (associated(MS%tv%T)) T_pre_dyn(i,j,k) = MS%tv%T(i,j,k) + if (associated(MS%tv%S)) S_pre_dyn(i,j,k) = MS%tv%S(i,j,k) enddo ; enddo ; enddo endif @@ -720,9 +726,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif mass_src_time = CS%t_dyn_rel_thermo - call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, & + call step_MOM_dyn_split_RK2(u, v, h, MS%tv, CS%visc, & Time_local, dt, forces, CS%p_surf_begin, CS%p_surf_end, & - mass_src_time, dt_therm, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + mass_src_time, dt_therm, MS%uh, MS%vh, MS%uhtr, MS%vhtr, & eta_av, G, GV, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, CS%MEKE) if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_split (step_MOM)") @@ -735,12 +741,12 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! useful for debugging purposes. if (CS%use_RK2) then - call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & - CS%p_surf_begin, CS%p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + call step_MOM_dyn_unsplit_RK2(u, v, h, MS%tv, CS%visc, Time_local, dt, forces, & + CS%p_surf_begin, CS%p_surf_end, MS%uh, MS%vh, MS%uhtr, MS%vhtr, & eta_av, G, GV, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE) else - call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & - CS%p_surf_begin, CS%p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + call step_MOM_dyn_unsplit(u, v, h, MS%tv, CS%visc, Time_local, dt, forces, & + CS%p_surf_begin, CS%p_surf_end, MS%uh, MS%vh, MS%uhtr, MS%vhtr, & eta_av, G, GV, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE) endif if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)") @@ -754,8 +760,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, & + call calc_slope_functions(h, MS%tv, dt, G, GV, CS%VarMix) + call thickness_diffuse(h, MS%uhtr, MS%vhtr, MS%tv, dt, G, GV, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_m) @@ -769,17 +775,17 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) if (CS%debug) then call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_m) call uvchksum("Pre-mixedlayer_restrat uhtr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m) + MS%uhtr, MS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m) endif call cpu_clock_begin(id_clock_ml_restrat) - call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & + call mixedlayer_restrat(h, MS%uhtr, MS%vhtr, MS%tv, forces, dt, CS%visc%MLD, & CS%VarMix, G, GV, CS%mixedlayer_restrat_CSp) call cpu_clock_end(id_clock_ml_restrat) call pass_var(h, G%Domain, clock=id_clock_pass) !###, halo=max(2,cont_stensil)) if (CS%debug) then call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_m) call uvchksum("Post-mixedlayer_restrat [uv]htr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m) + MS%uhtr, MS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m) endif endif @@ -788,7 +794,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) call diag_update_remap_grids(CS%diag) if (CS%useMEKE) call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, & - CS%visc, dt, G, GV, CS%MEKE_CSp, CS%uhtr, CS%vhtr) + CS%visc, dt, G, GV, CS%MEKE_CSp, MS%uhtr, MS%vhtr) call disable_averaging(CS%diag) ! Advance the dynamics time by dt. @@ -808,8 +814,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif if (do_advection) then ! Do advective transport and lateral tracer mixing. - call step_MOM_tracer_dyn(CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & - CS%tv, Time_local) + call step_MOM_tracer_dyn(MS, CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & + MS%tv, Time_local) endif !=========================================================================== @@ -822,7 +828,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) "before call to diabatic.") endif ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, Time_local, .false.) + call step_MOM_thermo(MS, CS, G, GV, u, v, h, MS%tv, fluxes, dtdia, Time_local, .false.) endif if (CS%diabatic_first .and. abs(CS%t_dyn_rel_thermo) > 1e-6*dt) call MOM_error(FATAL, & @@ -837,7 +843,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! Determining the time-average sea surface height is part of the algorithm. ! This may be eta_av if Boussinesq, or need to be diagnosed if not. tot_wt_ssh = tot_wt_ssh + dt - call find_eta(h, CS%tv, GV%g_Earth, G, GV, ssh, eta_av) + call find_eta(h, MS%tv, GV%g_Earth, G, GV, ssh, eta_av) do j=js,je ; do i=is,ie CS%ave_ssh(i,j) = CS%ave_ssh(i,j) + dt*ssh(i,j) enddo ; enddo @@ -859,7 +865,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) ! Diagnostics that require the complete state to be up-to-date can be calculated. call enable_averaging(CS%t_dyn_rel_diag, Time_local, CS%diag) - call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & + call calculate_diagnostic_fields(u, v, h, MS%uh, MS%vh, MS%tv, CS%ADp, & CS%CDp, fluxes, CS%t_dyn_rel_diag, G, GV, CS%diagnostics_CSp) call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag, G, GV, CS%t_dyn_rel_diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") @@ -891,19 +897,19 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) CS%ave_ssh(i,j) = CS%ave_ssh(i,j)*Itot_wt_ssh ssh(i,j) = CS%ave_ssh(i,j) enddo ; enddo - call adjust_ssh_for_p_atm(CS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) + call adjust_ssh_for_p_atm(MS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) if (CS%interp_p_surf) then ; do j=jsd,jed ; do i=isd,ied CS%p_surf_prev(i,j) = forces%p_surf(i,j) enddo ; enddo ; endif if (showCallTree) call callTree_waypoint("calling calculate_surface_state (step_MOM)") - call calculate_surface_state(sfc_state, u, v, h, CS%ave_ssh, G, GV, CS) + call calculate_surface_state(sfc_state, u, v, h, CS%ave_ssh, G, GV, MS, CS) ! Do diagnostics that only occur at the end of a complete forcing step. call cpu_clock_begin(id_clock_diagnostics) call enable_averaging(dt*n_max, Time_local, CS%diag) - call post_surface_diagnostics(CS%sfc_IDs, G, GV, CS%diag, dt*n_max, sfc_state, CS%tv, ssh, fluxes) + call post_surface_diagnostics(CS%sfc_IDs, G, GV, CS%diag, dt*n_max, sfc_state, MS%tv, ssh, fluxes) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -917,8 +923,9 @@ end subroutine step_MOM !> step_MOM_tracer_dyn does tracer advection and lateral diffusion, bringing the !! tracers up to date with the changes in state due to the dynamics. Surface !! sources and sinks and remapping are handled via step_MOM_thermo. -subroutine step_MOM_tracer_dyn(CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & +subroutine step_MOM_tracer_dyn(MS, CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & tv, Time_local) + type(MOM_state_type), intent(inout) :: MS !< structure describing the MOM state type(MOM_control_struct), intent(inout) :: CS !< control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -939,30 +946,30 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & if (CS%debug) then call cpu_clock_begin(id_clock_other) call hchksum(h,"Pre-advection h", G%HI, haloshift=1, scale=GV%H_to_m) - call uvchksum("Pre-advection uhtr", CS%uhtr, CS%vhtr, G%HI, & + call uvchksum("Pre-advection uhtr", MS%uhtr, MS%vhtr, G%HI, & haloshift=0, scale=GV%H_to_m) - if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1) - if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1) - if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, & + if (associated(MS%tv%T)) call hchksum(MS%tv%T, "Pre-advection T", G%HI, haloshift=1) + if (associated(MS%tv%S)) call hchksum(MS%tv%S, "Pre-advection S", G%HI, haloshift=1) + if (associated(MS%tv%frazil)) call hchksum(MS%tv%frazil, & "Pre-advection frazil", G%HI, haloshift=0) - if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & + if (associated(MS%tv%salt_deficit)) call hchksum(MS%tv%salt_deficit, & "Pre-advection salt deficit", G%HI, haloshift=0) - ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G) + ! call MOM_thermo_chksum("Pre-advection ", MS%tv, G) call cpu_clock_end(id_clock_other) endif call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) call enable_averaging(CS%t_dyn_rel_adv, Time_local, CS%diag) - call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, & + call advect_tracer(h, MS%uhtr, MS%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, & - CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + CS%tracer_diff_CSp, CS%tracer_Reg, MS%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) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) - call post_transport_diagnostics(G, GV, CS%uhtr, CS%vhtr, h, CS%transport_IDs, & + call post_transport_diagnostics(G, GV, MS%uhtr, MS%vhtr, h, CS%transport_IDs, & CS%diag, CS%t_dyn_rel_adv, CS%diag_to_Z_CSp, h_pre_dyn, T_pre_dyn, S_pre_dyn) ! Rebuild the remap grids now that we've posted the fields which rely on thicknesses ! from before the dynamics calls @@ -974,8 +981,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn, & ! Reset the accumulated transports to 0 and record that the dynamics ! and advective times now agree. call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) - CS%uhtr(:,:,:) = 0.0 - CS%vhtr(:,:,:) = 0.0 + MS%uhtr(:,:,:) = 0.0 + MS%vhtr(:,:,:) = 0.0 CS%t_dyn_rel_adv = 0.0 call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) @@ -989,7 +996,8 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. -subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_thermo, update_BBL) +subroutine step_MOM_thermo(MS, CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_thermo, update_BBL) + type(MOM_state_type), intent(inout) :: MS !< structure describing the MOM state type(MOM_control_struct), intent(inout) :: CS !< control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1023,8 +1031,8 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm if (CS%debug) then call uvchksum("Pre set_viscous_BBL [uv]", u, v, G%HI, haloshift=1) call hchksum(h,"Pre set_viscous_BBL h", G%HI, haloshift=1, scale=GV%H_to_m) - if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre set_viscous_BBL T", G%HI, haloshift=1) - if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre set_viscous_BBL S", G%HI, haloshift=1) + if (associated(MS%tv%T)) call hchksum(MS%tv%T, "Pre set_viscous_BBL T", G%HI, haloshift=1) + if (associated(MS%tv%S)) call hchksum(MS%tv%S, "Pre set_viscous_BBL S", G%HI, haloshift=1) endif ! Calculate the BBL properties and store them inside visc (u,h). @@ -1032,7 +1040,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm ! DIABATIC_FIRST=True. Otherwise diabatic() is called after the dynamics ! and set_viscous_BBL is called as a part of the dynamic stepping. call cpu_clock_begin(id_clock_BBL_visc) - call set_viscous_BBL(u, v, h, CS%tv, CS%visc, G, GV, CS%set_visc_CSp) + call set_viscous_BBL(u, v, h, MS%tv, CS%visc, G, GV, CS%set_visc_CSp) call cpu_clock_end(id_clock_BBL_visc) if (.not.G%Domain%symmetric) then @@ -1050,10 +1058,10 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm if (CS%debug) then call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2) call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) - call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & + call uvchksum("Pre-diabatic [uv]h", MS%uhtr, MS%vhtr, G%HI, & haloshift=0, scale=GV%H_to_m) - ! call MOM_state_chksum("Pre-diabatic ",u, v, h, CS%uhtr, CS%vhtr, G, GV) - call MOM_thermo_chksum("Pre-diabatic ", CS%tv, G,haloshift=0) + ! call MOM_state_chksum("Pre-diabatic ",u, v, h, MS%uhtr, MS%vhtr, G, GV) + call MOM_thermo_chksum("Pre-diabatic ", MS%tv, G,haloshift=0) call check_redundant("Pre-diabatic ", u, v, G) call MOM_forcing_chksum("Pre-diabatic", fluxes, G, haloshift=0) endif @@ -1077,7 +1085,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) if (CS%debug) then - call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV) + call MOM_state_chksum("Pre-ALE ", u, v, h, MS%uh, MS%vh, G, GV) call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1) call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1) call check_redundant("Pre-ALE ", u, v, G) @@ -1097,7 +1105,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm call do_group_pass(CS%pass_uv_T_S_h, G%Domain, clock=id_clock_pass) if (CS%debug .and. CS%use_ALE_algorithm) then - call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV) + call MOM_state_chksum("Post-ALE ", u, v, h, MS%uh, MS%vh, G, GV) call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1) call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1) call check_redundant("Post-ALE ", u, v, G) @@ -1114,10 +1122,10 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm if (CS%debug) then call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2) call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) - call uvchksum("Post-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & + call uvchksum("Post-diabatic [uv]h", MS%uhtr, MS%vhtr, G%HI, & haloshift=0, scale=GV%H_to_m) ! call MOM_state_chksum("Post-diabatic ", u, v, & - ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) + ! h, MS%uhtr, MS%vhtr, G, GV, haloshift=1) if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1) if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1) if (associated(tv%frazil)) call hchksum(tv%frazil, & @@ -1157,12 +1165,13 @@ end subroutine step_MOM_thermo !! developed with ALE configurations in mind. Some work has been done in isopycnal configuration, but !! the work is very preliminary. Some more detail about this capability along with some of the subroutines !! called here can be found in tracers/MOM_offline_control.F90 -subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS) +subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(surface), intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_interval !< time interval + type(MOM_state_type), pointer :: MS !< structure describing the MOM state type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM ! Local pointers @@ -1191,12 +1200,12 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS h_end ! 2D Array for diagnostics - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_pre, eta_end + real, dimension(SZI_(MS%G),SZJ_(MS%G)) :: eta_pre, eta_end type(time_type) :: Time_end ! End time of a segment, as a time type ! Grid-related pointer assignments - G => CS%G - GV => CS%GV + G => MS%G + GV => MS%GV is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1236,71 +1245,71 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if(is_root_pe()) print *, "Reading in new offline fields" ! Read in new transport and other fields ! call update_transport_from_files(G, GV, CS%offline_CSp, h_end, eatr, ebtr, uhtr, vhtr, & - ! CS%tv%T, CS%tv%S, fluxes, CS%use_ALE_algorithm) + ! MS%tv%T, MS%tv%S, fluxes, CS%use_ALE_algorithm) ! call update_transport_from_arrays(CS%offline_CSp) - call update_offline_fields(CS%offline_CSp, CS%h, fluxes, CS%use_ALE_algorithm) + call update_offline_fields(CS%offline_CSp, MS%h, fluxes, CS%use_ALE_algorithm) ! Apply any fluxes into the ocean - call offline_fw_fluxes_into_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) + call offline_fw_fluxes_into_ocean(G, GV, CS%offline_CSp, fluxes, MS%h) if (.not.CS%diabatic_first) then call offline_advection_ale(fluxes, Time_start, time_interval, CS%offline_CSp, id_clock_ALE, & - CS%h, uhtr, vhtr, converged=adv_converged) + MS%h, uhtr, vhtr, converged=adv_converged) ! Redistribute any remaining transport - call offline_redistribute_residual(CS%offline_CSp, CS%h, uhtr, vhtr, adv_converged) + call offline_redistribute_residual(CS%offline_CSp, MS%h, uhtr, vhtr, adv_converged) ! Perform offline diffusion if requested if (.not. skip_diffusion) then if (associated(CS%VarMix)) then - call pass_var(CS%h,G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, CS%VarMix) + call pass_var(MS%h,G%Domain) + call calc_resoln_function(MS%h, MS%tv, G, GV, CS%VarMix) + call calc_slope_functions(MS%h, MS%tv, REAL(dt_offline), G, GV, CS%VarMix) endif - call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & - CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + call tracer_hordiff(MS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & + CS%tracer_diff_CSp, CS%tracer_Reg, MS%tv) endif endif endif ! The functions related to column physics of tracers is performed separately in ALE mode if (do_vertical) then - call offline_diabatic_ale(fluxes, Time_start, Time_end, CS%offline_CSp, CS%h, eatr, ebtr) + call offline_diabatic_ale(fluxes, Time_start, Time_end, CS%offline_CSp, MS%h, eatr, ebtr) endif ! Last thing that needs to be done is the final ALE remapping if(last_iter) then if (CS%diabatic_first) then call offline_advection_ale(fluxes, Time_start, time_interval, CS%offline_CSp, id_clock_ALE, & - CS%h, uhtr, vhtr, converged=adv_converged) + MS%h, uhtr, vhtr, converged=adv_converged) ! Redistribute any remaining transport and perform the remaining advection - call offline_redistribute_residual(CS%offline_CSp, CS%h, uhtr, vhtr, adv_converged) + call offline_redistribute_residual(CS%offline_CSp, MS%h, uhtr, vhtr, adv_converged) ! Perform offline diffusion if requested if (.not. skip_diffusion) then if (associated(CS%VarMix)) then - call pass_var(CS%h,G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, CS%VarMix) + call pass_var(MS%h,G%Domain) + call calc_resoln_function(MS%h, MS%tv, G, GV, CS%VarMix) + call calc_slope_functions(MS%h, MS%tv, REAL(dt_offline), G, GV, CS%VarMix) endif - call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & - CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + call tracer_hordiff(MS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & + CS%tracer_diff_CSp, CS%tracer_Reg, MS%tv) endif endif if(is_root_pe()) print *, "Last iteration of offline interval" ! Apply freshwater fluxes out of the ocean - call offline_fw_fluxes_out_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) + call offline_fw_fluxes_out_ocean(G, GV, CS%offline_CSp, fluxes, MS%h) ! These diagnostic can be used to identify which grid points did not converge within ! the specified number of advection sub iterations - call post_offline_convergence_diags(CS%offline_CSp, CS%h, h_end, uhtr, vhtr) + call post_offline_convergence_diags(CS%offline_CSp, MS%h, h_end, uhtr, vhtr) ! Call ALE one last time to make sure that tracers are remapped onto the layer thicknesses ! stored from the forward run call cpu_clock_begin(id_clock_ALE) - call ALE_offline_tracer_final( G, GV, CS%h, CS%tv, h_end, CS%tracer_Reg, CS%ALE_CSp) + call ALE_offline_tracer_final( G, GV, MS%h, MS%tv, h_end, CS%tracer_Reg, CS%ALE_CSp) call cpu_clock_end(id_clock_ALE) - call pass_var(CS%h, G%Domain) + call pass_var(MS%h, G%Domain) endif else ! NON-ALE MODE...NOT WELL TESTED call MOM_error(WARNING, & @@ -1312,30 +1321,30 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif - call update_offline_fields(CS%offline_CSp, CS%h, fluxes, CS%use_ALE_algorithm) + call update_offline_fields(CS%offline_CSp, MS%h, fluxes, CS%use_ALE_algorithm) call offline_advection_layer(fluxes, Time_start, time_interval, CS%offline_CSp, & - CS%h, eatr, ebtr, uhtr, vhtr) + MS%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, & - CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + CS%tracer_diff_CSp, CS%tracer_Reg, MS%tv) endif - CS%h = h_end + MS%h = h_end - call pass_var(CS%tv%T, G%Domain) - call pass_var(CS%tv%S, G%Domain) - call pass_var(CS%h, G%Domain) + call pass_var(MS%tv%T, G%Domain) + call pass_var(MS%tv%S, G%Domain) + call pass_var(MS%h, G%Domain) endif - call adjust_ssh_for_p_atm(CS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) - call calculate_surface_state(sfc_state, CS%u, CS%v, CS%h, CS%ave_ssh, G, GV, CS) + call adjust_ssh_for_p_atm(MS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) + call calculate_surface_state(sfc_state, MS%u, MS%v, MS%h, CS%ave_ssh, G, GV, MS, CS) call disable_averaging(CS%diag) - call pass_var(CS%tv%T,G%Domain) - call pass_var(CS%tv%S,G%Domain) - call pass_var(CS%h,G%Domain) + call pass_var(MS%tv%T,G%Domain) + call pass_var(MS%tv%S,G%Domain) + call pass_var(MS%h,G%Domain) fluxes%fluxes_used = .true. @@ -1344,10 +1353,11 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS end subroutine step_offline !> This subroutine initializes MOM. -subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mode, input_restart_file) +subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, offline_tracer_mode, input_restart_file) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(param_file_type), intent(out) :: param_file !< structure indicating paramater file to parse type(directories), intent(out) :: dirs !< structure with directory paths + type(MOM_state_type), pointer :: MS !< pointer set in this routine to structure describing the MOM state type(MOM_control_struct), pointer :: CS !< pointer set in this routine to MOM control structure type(time_type), optional, intent(in) :: Time_in !< time passed to MOM_initialize_state when !! model is not being started from a restart file @@ -1419,8 +1429,14 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo endif allocate(CS) + if (associated(MS)) then + call MOM_error(WARNING, "initialize_MOM called with an MOM state structure.") + return + endif + allocate(MS) + if (test_grid_copy) then ; allocate(G) - else ; G => CS%G ; endif + else ; G => MS%G ; endif CS%Time => Time @@ -1485,7 +1501,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo "to potential temperature and practical salinity before \n"//& "exchanging them with the coupler and/or reporting T&S diagnostics.\n", & default=.false.) - CS%tv%T_is_conT = use_conT_absS ; CS%tv%S_is_absS = use_conT_absS + MS%tv%T_is_conT = use_conT_absS ; MS%tv%S_is_absS = use_conT_absS call get_param(param_file, "MOM", "ADIABATIC", CS%adiabatic, & "There are no diapycnal mass fluxes if ADIABATIC is \n"//& "true. This assumes that KD = KDML = 0.0 and that \n"//& @@ -1606,7 +1622,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo endif ! This is here in case these values are used inappropriately. - CS%use_frazil = .false. ; CS%bound_salinity = .false. ; CS%tv%P_Ref = 2.0e7 + CS%use_frazil = .false. ; CS%bound_salinity = .false. ; MS%tv%P_Ref = 2.0e7 if (CS%use_temperature) then call get_param(param_file, "MOM", "FRAZIL", CS%use_frazil, & "If true, water freezes if it gets too cold, and the \n"//& @@ -1619,14 +1635,14 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo "If true, limit salinity to being positive. (The sea-ice \n"//& "model may ask for more salt than is available and \n"//& "drive the salinity negative otherwise.)", default=.false.) - call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & + call get_param(param_file, "MOM", "C_P", MS%tv%C_p, & "The heat capacity of sea water, approximated as a \n"//& "constant. This is only used if ENABLE_THERMODYNAMICS is \n"//& "true. The default value is from the TEOS-10 definition \n"//& "of conservative temperature.", units="J kg-1 K-1", & default=3991.86795711963) endif - if (use_EOS) call get_param(param_file, "MOM", "P_REF", CS%tv%P_Ref, & + if (use_EOS) call get_param(param_file, "MOM", "P_REF", MS%tv%P_Ref, & "The pressure that is used for calculating the coordinate \n"//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) \n"//& "This is only used if USE_EOS and ENABLE_THERMODYNAMICS \n"//& @@ -1759,8 +1775,8 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call create_dyn_horgrid(dG, HI, bathymetry_at_vel=bathy_at_vel) call clone_MOM_domain(G%Domain, dG%Domain) - call verticalGridInit( param_file, CS%GV ) - GV => CS%GV + call verticalGridInit( param_file, MS%GV ) + GV => MS%GV ! dG%g_Earth = GV%g_Earth ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. @@ -1783,25 +1799,25 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo is = dG%isc ; ie = dG%iec ; js = dG%jsc ; je = dG%jec ; nz = GV%ke isd = dG%isd ; ied = dG%ied ; jsd = dG%jsd ; jed = dG%jed IsdB = dG%IsdB ; IedB = dG%IedB ; JsdB = dG%JsdB ; JedB = dG%JedB - ALLOC_(CS%u(IsdB:IedB,jsd:jed,nz)) ; CS%u(:,:,:) = 0.0 - ALLOC_(CS%v(isd:ied,JsdB:JedB,nz)) ; CS%v(:,:,:) = 0.0 - ALLOC_(CS%h(isd:ied,jsd:jed,nz)) ; CS%h(:,:,:) = GV%Angstrom - ALLOC_(CS%uh(IsdB:IedB,jsd:jed,nz)) ; CS%uh(:,:,:) = 0.0 - ALLOC_(CS%vh(isd:ied,JsdB:JedB,nz)) ; CS%vh(:,:,:) = 0.0 + ALLOC_(MS%u(IsdB:IedB,jsd:jed,nz)) ; MS%u(:,:,:) = 0.0 + ALLOC_(MS%v(isd:ied,JsdB:JedB,nz)) ; MS%v(:,:,:) = 0.0 + ALLOC_(MS%h(isd:ied,jsd:jed,nz)) ; MS%h(:,:,:) = GV%Angstrom + ALLOC_(MS%uh(IsdB:IedB,jsd:jed,nz)) ; MS%uh(:,:,:) = 0.0 + ALLOC_(MS%vh(isd:ied,JsdB:JedB,nz)) ; MS%vh(:,:,:) = 0.0 if (CS%use_temperature) then - ALLOC_(CS%T(isd:ied,jsd:jed,nz)) ; CS%T(:,:,:) = 0.0 - ALLOC_(CS%S(isd:ied,jsd:jed,nz)) ; CS%S(:,:,:) = 0.0 - CS%tv%T => CS%T ; CS%tv%S => CS%S - if (CS%tv%T_is_conT) then + ALLOC_(MS%T(isd:ied,jsd:jed,nz)) ; MS%T(:,:,:) = 0.0 + ALLOC_(MS%S(isd:ied,jsd:jed,nz)) ; MS%S(:,:,:) = 0.0 + MS%tv%T => MS%T ; MS%tv%S => MS%S + if (MS%tv%T_is_conT) then CS%vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & - conversion=CS%tv%C_p) + conversion=MS%tv%C_p) else CS%vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & - conversion=CS%tv%C_p) + conversion=MS%tv%C_p) endif - if (CS%tv%S_is_absS) then + if (MS%tv%S_is_absS) then CS%vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & conversion=0.001) @@ -1813,7 +1829,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo if(CS%advect_TS) then S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? - conv2watt = GV%H_to_kg_m2 * CS%tv%C_p + conv2watt = GV%H_to_kg_m2 * MS%tv%C_p if (GV%Boussinesq) then conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? H_convert = GV%H_to_m @@ -1821,25 +1837,25 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo conv2salt = GV%H_to_kg_m2 H_convert = GV%H_to_kg_m2 endif - call register_tracer(CS%tv%T, CS%tracer_Reg, param_file, dG%HI, GV, & + call register_tracer(MS%tv%T, CS%tracer_Reg, param_file, dG%HI, GV, & tr_desc=CS%vd_T, registry_diags=.true., flux_nameroot='T', & flux_units='W m-2', flux_longname='Heat', & flux_scale=conv2watt, convergence_units='W m-2', & convergence_scale=conv2watt, CMOR_tendname="opottemptend", diag_form=2) - call register_tracer(CS%tv%S, CS%tracer_Reg, param_file, dG%HI, GV, & + call register_tracer(MS%tv%S, CS%tracer_Reg, param_file, dG%HI, GV, & tr_desc=CS%vd_S, registry_diags=.true., flux_nameroot='S', & flux_units=S_flux_units, flux_longname='Salt', & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendname="osalttend", diag_form=2) endif if (associated(CS%OBC)) & - call register_temp_salt_segments(GV, CS%OBC, CS%tv, CS%vd_T, CS%vd_S, param_file) + call register_temp_salt_segments(GV, CS%OBC, MS%tv, CS%vd_T, CS%vd_S, param_file) endif if (CS%use_frazil) then - allocate(CS%tv%frazil(isd:ied,jsd:jed)) ; CS%tv%frazil(:,:) = 0.0 + allocate(MS%tv%frazil(isd:ied,jsd:jed)) ; MS%tv%frazil(:,:) = 0.0 endif if (CS%bound_salinity) then - allocate(CS%tv%salt_deficit(isd:ied,jsd:jed)) ; CS%tv%salt_deficit(:,:)=0.0 + allocate(MS%tv%salt_deficit(isd:ied,jsd:jed)) ; MS%tv%salt_deficit(:,:)=0.0 endif if (CS%bulkmixedlayer .or. CS%use_temperature) then @@ -1855,8 +1871,8 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call get_param(param_file, "MOM", "NK_RHO_VARIES", GV%nk_rho_varies, default=0) ! Will default to nz later... -AJA endif - ALLOC_(CS%uhtr(IsdB:IedB,jsd:jed,nz)) ; CS%uhtr(:,:,:) = 0.0 - ALLOC_(CS%vhtr(isd:ied,JsdB:JedB,nz)) ; CS%vhtr(:,:,:) = 0.0 + ALLOC_(MS%uhtr(IsdB:IedB,jsd:jed,nz)) ; MS%uhtr(:,:,:) = 0.0 + ALLOC_(MS%vhtr(isd:ied,JsdB:JedB,nz)) ; MS%vhtr(:,:,:) = 0.0 CS%t_dyn_rel_adv = 0.0 ; CS%t_dyn_rel_thermo = 0.0 ; CS%t_dyn_rel_diag = 0.0 if (CS%debug_truncations) then @@ -1870,14 +1886,14 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo endif endif - MOM_internal_state%u => CS%u ; MOM_internal_state%v => CS%v - MOM_internal_state%h => CS%h - MOM_internal_state%uh => CS%uh ; MOM_internal_state%vh => CS%vh + MOM_internal_state%u => MS%u ; MOM_internal_state%v => MS%v + MOM_internal_state%h => MS%h + MOM_internal_state%uh => MS%uh ; MOM_internal_state%vh => MS%vh if (CS%use_temperature) then - MOM_internal_state%T => CS%T ; MOM_internal_state%S => CS%S + MOM_internal_state%T => MS%T ; MOM_internal_state%S => MS%S endif - CS%CDp%uh => CS%uh ; CS%CDp%vh => CS%vh + CS%CDp%uh => MS%uh ; CS%CDp%vh => MS%vh if (CS%interp_p_surf) then allocate(CS%p_surf_prev(isd:ied,jsd:jed)) ; CS%p_surf_prev(:,:) = 0.0 @@ -1888,13 +1904,13 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! Use the Wright equation of state by default, unless otherwise specified ! Note: this line and the following block ought to be in a separate ! initialization routine for tv. - if (use_EOS) call EOS_init(param_file, CS%tv%eqn_of_state) + if (use_EOS) call EOS_init(param_file, MS%tv%eqn_of_state) if (CS%use_temperature) then - allocate(CS%tv%TempxPmE(isd:ied,jsd:jed)) - CS%tv%TempxPmE(:,:) = 0.0 + allocate(MS%tv%TempxPmE(isd:ied,jsd:jed)) + MS%tv%TempxPmE(:,:) = 0.0 if (use_geothermal) then - allocate(CS%tv%internal_heat(isd:ied,jsd:jed)) - CS%tv%internal_heat(:,:) = 0.0 + allocate(MS%tv%internal_heat(isd:ied,jsd:jed)) + MS%tv%internal_heat(:,:) = 0.0 endif endif call callTree_waypoint("state variables allocated (initialize_MOM)") @@ -1902,10 +1918,10 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! Set the fields that are needed for bitwise identical restarting ! the time stepping scheme. call restart_init(param_file, CS%restart_CSp) - call set_restart_fields(GV, param_file, CS) + call set_restart_fields(GV, param_file, MS, CS) if (CS%split) then call register_restarts_dyn_split_RK2(dG%HI, GV, param_file, & - CS%dyn_split_RK2_CSp, CS%restart_CSp, CS%uh, CS%vh) + CS%dyn_split_RK2_CSp, CS%restart_CSp, MS%uh, MS%vh) elseif (CS%use_RK2) then call register_restarts_dyn_unsplit_RK2(dG%HI, GV, param_file, & CS%dyn_unsplit_RK2_CSp, CS%restart_CSp) @@ -1931,7 +1947,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! Initialize dynamically evolving fields, perhaps from restart files. call cpu_clock_begin(id_clock_MOM_init) call MOM_initialize_coord(GV, param_file, write_geom_files, & - dirs%output_directory, CS%tv, dG%max_depth) + dirs%output_directory, MS%tv, dG%max_depth) call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") if (CS%use_ALE_algorithm) then @@ -1956,7 +1972,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! Consider removing this later? G%ke = GV%ke ; G%g_Earth = GV%g_Earth - call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, param_file, & + call MOM_initialize_state(MS%u, MS%v, MS%h, MS%tv, Time, G, GV, param_file, & dirs, CS%restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & CS%sponge_CSp, CS%ALE_sponge_CSp, CS%OBC, Time_in) call cpu_clock_end(id_clock_MOM_init) @@ -1966,22 +1982,22 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! that will persist throughout the run has to be used. if (test_grid_copy) then - ! Copy the data from the temporary grid to the dyn_hor_grid to CS%G. + ! Copy the data from the temporary grid to the dyn_hor_grid to MS%G. call create_dyn_horgrid(dG, G%HI) call clone_MOM_domain(G%Domain, dG%Domain) - call clone_MOM_domain(G%Domain, CS%G%Domain) - call MOM_grid_init(CS%G, param_file) + call clone_MOM_domain(G%Domain, MS%G%Domain) + call MOM_grid_init(MS%G, param_file) call copy_MOM_grid_to_dyngrid(G, dg) - call copy_dyngrid_to_MOM_grid(dg, CS%G) + call copy_dyngrid_to_MOM_grid(dg, MS%G) call destroy_dyn_horgrid(dG) call MOM_grid_end(G) ; deallocate(G) - G => CS%G - if (CS%debug .or. CS%G%symmetric) & - call clone_MOM_domain(CS%G%Domain, CS%G%Domain_aux, symmetric=.false.) + G => MS%G + if (CS%debug .or. MS%G%symmetric) & + call clone_MOM_domain(MS%G%Domain, MS%G%Domain_aux, symmetric=.false.) G%ke = GV%ke ; G%g_Earth = GV%g_Earth endif @@ -1990,17 +2006,17 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo ! remainder of this subroutine is controlled by the parameters that have ! have already been set. - if (ALE_remap_init_conds(CS%ALE_CSp) .and. .not. query_initialized(CS%h,"h",CS%restart_CSp)) then + if (ALE_remap_init_conds(CS%ALE_CSp) .and. .not. query_initialized(MS%h,"h",CS%restart_CSp)) then ! This block is controlled by the ALE parameter REMAP_AFTER_INITIALIZATION. ! \todo This block exists for legacy reasons and we should phase it out of ! all examples. !### if (CS%debug) then call uvchksum("Pre ALE adjust init cond [uv]", & - CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) + MS%u, MS%v, G%HI, haloshift=1) + call hchksum(MS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") - call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) + call adjustGridForIntegrity(CS%ALE_CSp, G, GV, MS%h ) call callTree_waypoint("Calling ALE_main() to remap initial conditions (initialize_MOM)") if (use_ice_shelf) then filename = trim(inputdir)//trim(ice_shelf_file) @@ -2019,25 +2035,25 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo enddo ; enddo ! pass to the pointer shelf_area => frac_shelf_h - call ALE_main(G, GV, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, & + call ALE_main(G, GV, MS%h, MS%u, MS%v, MS%tv, CS%tracer_Reg, CS%ALE_CSp, & frac_shelf_h = shelf_area) else - call ALE_main( G, GV, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp ) + call ALE_main( G, GV, MS%h, MS%u, MS%v, MS%tv, CS%tracer_Reg, CS%ALE_CSp ) endif call cpu_clock_begin(id_clock_pass_init) - call create_group_pass(tmp_pass_uv_T_S_h, CS%u, CS%v, G%Domain) + call create_group_pass(tmp_pass_uv_T_S_h, MS%u, MS%v, G%Domain) if (CS%use_temperature) then - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain, halo=1) - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, MS%tv%T, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, MS%tv%S, G%Domain, halo=1) endif - call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, MS%h, G%Domain, halo=1) call do_group_pass(tmp_pass_uv_T_S_h, G%Domain) call cpu_clock_end(id_clock_pass_init) if (CS%debug) then - call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) + call uvchksum("Post ALE adjust init cond [uv]", MS%u, MS%v, G%HI, haloshift=1) + call hchksum(MS%h, "Post ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) endif endif if ( CS%use_ALE_algorithm ) call ALE_updateVerticalGridType( CS%ALE_CSp, GV ) @@ -2052,8 +2068,8 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call diag_masks_set(G, GV%ke, diag) ! Set up pointers within diag mediator control structure, - ! this needs to occur _after_ CS%h etc. have been allocated. - call diag_set_state_ptrs(CS%h, CS%T, CS%S, CS%tv%eqn_of_state, diag) + ! this needs to occur _after_ MS%h etc. have been allocated. + call diag_set_state_ptrs(MS%h, MS%T, MS%S, MS%tv%eqn_of_state, diag) ! This call sets up the diagnostic axes. These are needed, ! e.g. to generate the target grids below. @@ -2071,7 +2087,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call set_masks_for_axes(G, diag) ! Diagnose static fields AND associate areas/volumes with axes - call write_static_fields(G, GV, CS%tv, CS%diag) + call write_static_fields(G, GV, MS%tv, CS%diag) call callTree_waypoint("static fields written (initialize_MOM)") ! Register the volume cell measure (must be one of first diagnostics) @@ -2090,18 +2106,18 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call set_visc_init(Time, G, GV, param_file, diag, CS%visc, CS%set_visc_CSp,CS%OBC) if (CS%split) then allocate(eta(SZI_(G),SZJ_(G))) ; eta(:,:) = 0.0 - call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & + call initialize_dyn_split_RK2(MS%u, MS%v, MS%h, MS%uh, MS%vh, eta, Time, & G, GV, param_file, diag, CS%dyn_split_RK2_CSp, CS%restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc) elseif (CS%use_RK2) then - call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, & + call initialize_dyn_unsplit_RK2(MS%u, MS%v, MS%h, Time, G, GV, & param_file, diag, CS%dyn_unsplit_RK2_CSp, CS%restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, CS%update_OBC_CSp, & CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, CS%ntrunc) else - call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, & + call initialize_dyn_unsplit(MS%u, MS%v, MS%h, Time, G, GV, & param_file, diag, CS%dyn_unsplit_CSp, CS%restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, CS%update_OBC_CSp, & CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, CS%ntrunc) @@ -2120,7 +2136,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo endif call MOM_diagnostics_init(MOM_internal_state, CS%ADp, CS%CDp, Time, G, GV, & - param_file, diag, CS%diagnostics_CSp, CS%tv) + param_file, diag, CS%diagnostics_CSp, MS%tv) CS%Z_diag_interval = set_time(int((CS%dt_therm) * & max(1,floor(0.01 + Z_diag_int/(CS%dt_therm))))) @@ -2150,20 +2166,20 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call callTree_waypoint("tracer registry now locked (initialize_MOM)") ! now register some diagnostics since the tracer registry is now locked - call register_surface_diags(Time, G, CS%sfc_IDs, CS%diag, CS%missing, CS%tv) + call register_surface_diags(Time, G, CS%sfc_IDs, CS%diag, CS%missing, MS%tv) call register_diags(Time, G, GV, CS%IDs, CS%diag, CS%missing) call register_transport_diags(Time, G, GV, CS%transport_IDs, CS%diag, CS%missing) - call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & + call register_tracer_diagnostics(CS%tracer_Reg, MS%h, Time, diag, G, GV, & CS%use_ALE_algorithm, CS%diag_to_Z_CSp) if (CS%use_ALE_algorithm) then - call ALE_register_diags(Time, G, GV, diag, CS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) + call ALE_register_diags(Time, G, GV, diag, MS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) endif ! This subroutine initializes any tracer packages. new_sim = is_new_run(CS%restart_CSp) - call tracer_flow_control_init(.not.new_sim, Time, G, GV, CS%h, param_file, & + call tracer_flow_control_init(.not.new_sim, Time, G, GV, MS%h, param_file, & CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & - CS%ALE_sponge_CSp, CS%diag_to_Z_CSp, CS%tv) + CS%ALE_sponge_CSp, CS%diag_to_Z_CSp, MS%tv) ! If running in offline tracer mode, initialize the necessary control structure and @@ -2176,19 +2192,19 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & - tv=CS%tv, x_before_y = (MOD(first_direction,2)==0), debug=CS%debug ) + tv=MS%tv, x_before_y = (MOD(first_direction,2)==0), debug=CS%debug ) call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp) endif !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM call cpu_clock_begin(id_clock_pass_init) dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) - call create_group_pass(CS%pass_uv_T_S_h, CS%u, CS%v, G%Domain, halo=dynamics_stencil) + call create_group_pass(CS%pass_uv_T_S_h, MS%u, MS%v, G%Domain, halo=dynamics_stencil) if (CS%use_temperature) then - call create_group_pass(CS%pass_uv_T_S_h, CS%tv%T, G%Domain, halo=dynamics_stencil) - call create_group_pass(CS%pass_uv_T_S_h, CS%tv%S, G%Domain, halo=dynamics_stencil) + call create_group_pass(CS%pass_uv_T_S_h, MS%tv%T, G%Domain, halo=dynamics_stencil) + call create_group_pass(CS%pass_uv_T_S_h, MS%tv%S, G%Domain, halo=dynamics_stencil) endif - call create_group_pass(CS%pass_uv_T_S_h, CS%h, G%Domain, halo=dynamics_stencil) + call create_group_pass(CS%pass_uv_T_S_h, MS%h, G%Domain, halo=dynamics_stencil) call do_group_pass(CS%pass_uv_T_S_h, G%Domain) @@ -2198,11 +2214,11 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call cpu_clock_end(id_clock_pass_init) call register_obsolete_diagnostics(param_file, CS%diag) - call neutral_diffusion_diag_init(Time, G, diag, CS%tv%C_p, CS%tracer_Reg, CS%neutral_diffusion_CSp) + call neutral_diffusion_diag_init(Time, G, diag, MS%tv%C_p, CS%tracer_Reg, CS%neutral_diffusion_CSp) if (CS%use_frazil) then - if (.not.query_initialized(CS%tv%frazil,"frazil",CS%restart_CSp)) & - CS%tv%frazil(:,:) = 0.0 + if (.not.query_initialized(MS%tv%frazil,"frazil",CS%restart_CSp)) & + MS%tv%frazil(:,:) = 0.0 endif if (CS%interp_p_surf) then @@ -2214,9 +2230,9 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo if (.not.query_initialized(CS%ave_ssh,"ave_ssh",CS%restart_CSp)) then if (CS%split) then - call find_eta(CS%h, CS%tv, GV%g_Earth, G, GV, CS%ave_ssh, eta) + call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, CS%ave_ssh, eta) else - call find_eta(CS%h, CS%tv, GV%g_Earth, G, GV, CS%ave_ssh) + call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, CS%ave_ssh) endif endif if (CS%split) deallocate(eta) @@ -2232,10 +2248,11 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo end subroutine initialize_MOM !> This subroutine finishes initializing MOM and writes out the initial conditions. -subroutine finish_MOM_initialization(Time, dirs, CS, fluxes) +subroutine finish_MOM_initialization(Time, dirs, MS, CS, fluxes) type(time_type), intent(in) :: Time !< model time, used in this routine type(directories), intent(in) :: dirs !< structure with directory paths - type(MOM_control_struct), pointer :: CS !< pointer set in this routine to MOM control structure + type(MOM_state_type), pointer :: MS !< pointer to structure describing the MOM state + type(MOM_control_struct), pointer :: CS !< pointer to MOM control structure type(forcing), intent(inout) :: fluxes !< pointers to forcing fields ! Local variables type(ocean_grid_type), pointer :: G => NULL() @@ -2249,14 +2266,14 @@ subroutine finish_MOM_initialization(Time, dirs, CS, fluxes) call callTree_enter("finish_MOM_initialization()") ! Pointers for convenience - G => CS%G ; GV => CS%GV + G => MS%G ; GV => MS%GV ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) restart_CSp_tmp = CS%restart_CSp allocate(z_interface(SZI_(G),SZJ_(G),SZK_(G)+1)) - call find_eta(CS%h, CS%tv, GV%g_Earth, G, GV, z_interface) + call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, z_interface) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & "Interface heights", "meter", z_grid='i') @@ -2634,9 +2651,10 @@ end subroutine write_static_fields !! This routine should be altered if there are any changes to the !! time stepping scheme. The CHECK_RESTART facility may be used to !! confirm that all needed restart fields have been included. -subroutine set_restart_fields(GV, param_file, CS) +subroutine set_restart_fields(GV, param_file, MS, CS) type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure type(param_file_type), intent(in) :: param_file !< opened file for parsing to get parameters + type(MOM_state_type), intent(in) :: MS !< structure describing the MOM state type(MOM_control_struct), intent(in) :: CS !< control structure set up by inialize_MOM ! Local variables logical :: use_ice_shelf ! Needed to determine whether to add CS%Hml to restarts @@ -2648,23 +2666,23 @@ subroutine set_restart_fields(GV, param_file, CS) flux_units = get_flux_units(GV) if (CS%use_temperature) then - call register_restart_field(CS%tv%T, "Temp", .true., CS%restart_CSp, & + call register_restart_field(MS%tv%T, "Temp", .true., CS%restart_CSp, & "Potential Temperature", "degC") - call register_restart_field(CS%tv%S, "Salt", .true., CS%restart_CSp, & + call register_restart_field(MS%tv%S, "Salt", .true., CS%restart_CSp, & "Salinity", "PPT") endif - call register_restart_field(CS%h, "h", .true., CS%restart_CSp, & + call register_restart_field(MS%h, "h", .true., CS%restart_CSp, & "Layer Thickness", thickness_units) - call register_restart_field(CS%u, "u", .true., CS%restart_CSp, & + call register_restart_field(MS%u, "u", .true., CS%restart_CSp, & "Zonal velocity", "m s-1", hor_grid='Cu') - call register_restart_field(CS%v, "v", .true., CS%restart_CSp, & + call register_restart_field(MS%v, "v", .true., CS%restart_CSp, & "Meridional velocity", "m s-1", hor_grid='Cv') if (CS%use_frazil) then - call register_restart_field(CS%tv%frazil, "frazil", .false., CS%restart_CSp, & + call register_restart_field(MS%tv%frazil, "frazil", .false., CS%restart_CSp, & "Frazil heat flux into ocean", "J m-2") endif @@ -2782,7 +2800,7 @@ end subroutine allocate_surface_state !> This subroutine sets the surface (return) properties of the ocean !! model by setting the appropriate fields in state. Unused fields !! are set to NULL or are unallocated. -subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) +subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, MS, CS) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state @@ -2790,6 +2808,7 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< meridional velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness (m or kg/m2) real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh !< time mean surface height (m) + type(MOM_state_type), intent(in) :: MS !< structure describing the MOM state type(MOM_control_struct), intent(inout) :: CS !< control structure ! local @@ -2817,11 +2836,11 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) ! integrals, since the 3-d sums are not negligible in cost. call allocate_surface_state(sfc_state, G, CS%use_temperature, do_integrals=.true.) endif - sfc_state%frazil => CS%tv%frazil - sfc_state%TempxPmE => CS%tv%TempxPmE - sfc_state%internal_heat => CS%tv%internal_heat - sfc_state%T_is_conT = CS%tv%T_is_conT - sfc_state%S_is_absS = CS%tv%S_is_absS + sfc_state%frazil => MS%tv%frazil + sfc_state%TempxPmE => MS%tv%TempxPmE + sfc_state%internal_heat => MS%tv%internal_heat + sfc_state%T_is_conT = MS%tv%T_is_conT + sfc_state%S_is_absS = MS%tv%S_is_absS if (associated(CS%visc%taux_shelf)) sfc_state%taux_shelf => CS%visc%taux_shelf if (associated(CS%visc%tauy_shelf)) sfc_state%tauy_shelf => CS%visc%tauy_shelf @@ -2831,8 +2850,8 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) if (CS%bulkmixedlayer) then if (CS%use_temperature) then ; do j=js,je ; do i=is,ie - sfc_state%SST(i,j) = CS%tv%T(i,j,1) - sfc_state%SSS(i,j) = CS%tv%S(i,j,1) + sfc_state%SST(i,j) = MS%tv%T(i,j,1) + sfc_state%SSS(i,j) = MS%tv%S(i,j,1) enddo ; enddo ; endif do j=js,je ; do I=IscB,IecB sfc_state%u(I,j) = u(I,j,1) @@ -2868,8 +2887,8 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) dh = 0.0 endif if (CS%use_temperature) then - sfc_state%SST(i,j) = sfc_state%SST(i,j) + dh * CS%tv%T(i,j,k) - sfc_state%SSS(i,j) = sfc_state%SSS(i,j) + dh * CS%tv%S(i,j,k) + sfc_state%SST(i,j) = sfc_state%SST(i,j) + dh * MS%tv%T(i,j,k) + sfc_state%SSS(i,j) = sfc_state%SSS(i,j) + dh * MS%tv%S(i,j,k) else sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) + dh * GV%Rlay(k) endif @@ -2953,11 +2972,11 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) endif endif ! end BULKMIXEDLAYER - if (allocated(sfc_state%salt_deficit) .and. associated(CS%tv%salt_deficit)) then + if (allocated(sfc_state%salt_deficit) .and. associated(MS%tv%salt_deficit)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ! Convert from gSalt to kgSalt - sfc_state%salt_deficit(i,j) = 1000.0 * CS%tv%salt_deficit(i,j) + sfc_state%salt_deficit(i,j) = 1000.0 * MS%tv%salt_deficit(i,j) enddo ; enddo endif @@ -2972,9 +2991,9 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) do j=js,je ; do k=1,nz; do i=is,ie mass = GV%H_to_kg_m2*h(i,j,k) sfc_state%ocean_mass(i,j) = sfc_state%ocean_mass(i,j) + mass - sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass*CS%tv%T(i,j,k) + sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass*MS%tv%T(i,j,k) sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + & - mass * (1.0e-3*CS%tv%S(i,j,k)) + mass * (1.0e-3*MS%tv%S(i,j,k)) enddo ; enddo ; enddo else if (allocated(sfc_state%ocean_mass)) then @@ -2991,7 +3010,7 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) !$OMP parallel do default(shared) private(mass) do j=js,je ; do k=1,nz ; do i=is,ie mass = GV%H_to_kg_m2*h(i,j,k) - sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass*CS%tv%T(i,j,k) + sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass*MS%tv%T(i,j,k) enddo ; enddo ; enddo endif if (allocated(sfc_state%ocean_salt)) then @@ -3001,7 +3020,7 @@ subroutine calculate_surface_state(sfc_state, u, v, h, ssh, G, GV, CS) do j=js,je ; do k=1,nz ; do i=is,ie mass = GV%H_to_kg_m2*h(i,j,k) sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + & - mass * (1.0e-3*CS%tv%S(i,j,k)) + mass * (1.0e-3*MS%tv%S(i,j,k)) enddo ; enddo ; enddo endif endif @@ -3069,21 +3088,22 @@ end subroutine calculate_surface_state !> End of model -subroutine MOM_end(CS) +subroutine MOM_end(MS, CS) + type(MOM_state_type), pointer :: MS !< structure describing the MOM state type(MOM_control_struct), pointer :: CS !< MOM control structure if (CS%use_ALE_algorithm) then call ALE_end(CS%ALE_CSp) endif - DEALLOC_(CS%u) ; DEALLOC_(CS%v) ; DEALLOC_(CS%h) - DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) + DEALLOC_(MS%u) ; DEALLOC_(MS%v) ; DEALLOC_(MS%h) + DEALLOC_(MS%uh) ; DEALLOC_(MS%vh) if (CS%use_temperature) then - DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() + DEALLOC_(MS%T) ; MS%tv%T => NULL() ; DEALLOC_(MS%S) ; MS%tv%S => NULL() endif - if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) - if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) + if (associated(MS%tv%frazil)) deallocate(MS%tv%frazil) + if (associated(MS%tv%salt_deficit)) deallocate(MS%tv%salt_deficit) if (associated(CS%Hml)) deallocate(CS%Hml) call tracer_advect_end(CS%tracer_adv_CSp) @@ -3095,7 +3115,7 @@ subroutine MOM_end(CS) call offline_transport_end(CS%offline_CSp) endif - DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr) + DEALLOC_(MS%uhtr) ; DEALLOC_(MS%vhtr) if (CS%split) then call end_dyn_split_RK2(CS%dyn_split_RK2_CSp) elseif (CS%use_RK2) then @@ -3106,9 +3126,10 @@ subroutine MOM_end(CS) DEALLOC_(CS%ave_ssh) if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) - call verticalGridEnd(CS%GV) - call MOM_grid_end(CS%G) + call verticalGridEnd(MS%GV) + call MOM_grid_end(MS%G) + deallocate(MS) deallocate(CS) end subroutine MOM_end From 95bc47b95d41636af4db8fc8d5f2fe8ad3536cf5 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 24 Jan 2018 20:56:54 -0500 Subject: [PATCH 148/170] Replace FATALs/WARNINGs for modified channel widths - FATAL errors were being triggered in OM4_025 because Gibraltar spans several points. This is a design feature. - WARNINGS have been demoted to NOTEs except `mpp_error(NOTE,...)` can only be issued from `root_pe()` so I've resorted to `write(*,)`. - Limited checking/reporting to compute domain to avoid repeated messages about the same point. --- .../MOM_shared_initialization.F90 | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 500bdedde2..8bb7a290ee 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -910,14 +910,14 @@ subroutine reset_face_lengths_list(G, param_file) ((lon_m >= u_lon(1,npt)) .and. (lon_m <= u_lon(2,npt)))) ) then G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(u_width(npt), 0.0)) - if ( G%mask2dCu(I,j) == 0.0 ) then - write(mesg,'(A,I4,A)') "read_face_lengths_list : G%mask2dCu is not defined for line ",npt, & - "Please update values in "//trim(filename) - call MOM_error(FATAL, mesg, all_print=.true.) - else - write(mesg,'(A54,2F8.2,A2,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& - u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") to ",G%dy_Cu(I,j),"m" - call MOM_error(WARNING, mesg, all_print=.true.) + if (j>=G%jsc .and. j<=G%jec .and. I>=G%isc .and. I<=G%iec) then ! Limit messages/checking to compute domain + if ( G%mask2dCu(I,j) == 0.0 ) then + write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCu=0 at ",lat,lon," (",& + u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") so grid metric is unmodified." + else + write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& + u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") to ",G%dy_Cu(I,j),"m" + endif endif endif enddo @@ -938,14 +938,14 @@ subroutine reset_face_lengths_list(G, param_file) ((lon_p >= v_lon(1,npt)) .and. (lon_p <= v_lon(2,npt))) .or. & ((lon_m >= v_lon(1,npt)) .and. (lon_m <= v_lon(2,npt)))) ) then G%dx_Cv(i,J) = G%mask2dCv(i,J) * min(G%dxCv(i,J), max(v_width(npt), 0.0)) - if ( G%mask2dCv(I,j) == 0.0 ) then - write(mesg,'(A,I4,A)') "read_face_lengths_list : G%mask2dCv is not defined for line ",npt, & - "Please update values in "//trim(filename) - call MOM_error(FATAL, mesg, all_print=.true.) - else - write(mesg,'(A54,2F8.2,A2,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& - v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") to ",G%dx_Cv(I,j),"m" - call MOM_error(WARNING, mesg, all_print=.true.) + if (i>=G%isc .and. i<=G%iec .and. J>=G%jsc .and. J<=G%jec) then ! Limit messages/checking to compute domain + if ( G%mask2dCv(i,J) == 0.0 ) then + write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCv=0 at ",lat,lon," (",& + v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") so grid metric is unmodified." + else + write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& + v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") to ",G%dx_Cv(I,j),"m" + endif endif endif enddo From 4747b1d0784a8c4540b1729b1ee87da138ad0bea Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 25 Jan 2018 07:51:19 -0500 Subject: [PATCH 149/170] +Reduced use of MOM_CSp elements by drivers Moved t_dyn_rel_adv and ave_ssh from the MOM_control_structure to the MOM_state_type. Added an optional argument to ocean_model_init to set a pointer to the diag_ctrl type, and then used this to avoid using MOM_CSp%diag in the top-level drivers. Also avoided using MOM%CSp%use_temperature by querying whether tv%T is associated. All answers are bitwise identical, but there are several changes to interfaces and types. --- config_src/coupled_driver/ocean_model_MOM.F90 | 49 ++++++------ config_src/mct_driver/ocn_comp_mct.F90 | 42 +++++----- config_src/solo_driver/MOM_driver.F90 | 41 ++++++---- src/core/MOM.F90 | 78 ++++++++++--------- 4 files changed, 114 insertions(+), 96 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 6e28d30d9f..9ef1691806 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -208,6 +208,8 @@ module ocean_model_mod forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(sum_output_CS), pointer :: & sum_output_CSp => NULL() !< A pointer to the MOM sum output control structure + type(diag_ctrl), pointer :: & + diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type contains @@ -258,7 +260,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) character(len=48) :: stagger integer :: secs, days type(param_file_type) :: param_file !< A structure to parse for run-time parameters - logical :: offline_tracer_mode + logical :: offline_tracer_mode, use_temperature type(time_type) :: dt_geometric, dt_savedays, dt_from_base call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") @@ -274,10 +276,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%Time = Time_in call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, Time_in, & - offline_tracer_mode=offline_tracer_mode) + offline_tracer_mode=offline_tracer_mode, diag_ptr=OS%diag) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV OS%C_p = OS%MSp%tv%C_p OS%fluxes%C_p = OS%MSp%tv%C_p + use_temperature = ASSOCIATED(OS%MSp%tv%T) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -360,15 +363,15 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) ! Consider using a run-time flag to determine whether to do the diagnostic ! vertical integrals, since the related 3-d sums are not negligible in cost. - call allocate_surface_state(OS%sfc_state, OS%grid, OS%MOM_CSp%use_temperature, & + call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & do_integrals=.true., gas_fields_ocn=gas_fields_ocn) - call surface_forcing_init(Time_in, OS%grid, param_file, OS%MOM_CSp%diag, & + call surface_forcing_init(Time_in, OS%grid, param_file, OS%diag, & OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%MOM_CSp%diag, OS%forces, OS%fluxes) + OS%diag, OS%forces, OS%fluxes) endif if (OS%icebergs_apply_rigid_boundary) then !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) @@ -401,11 +404,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) if (ASSOCIATED(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%MOM_CSp%diag, maskmap=OS%grid%Domain%maskmap, & + OS%diag, maskmap=OS%grid%Domain%maskmap, & gas_fields_ocn=gas_fields_ocn) else call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%MOM_CSp%diag, gas_fields_ocn=gas_fields_ocn) + OS%diag, gas_fields_ocn=gas_fields_ocn) endif ! This call can only occur here if the coupler_bc_type variables have been @@ -415,7 +418,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) Ocean_sfc%axes(1:2), Time_in) call calculate_surface_state(OS%sfc_state, OS%MSp%u, & - OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%MSp%v, OS%MSp%h, OS%MSp%ave_ssh,& OS%grid, OS%GV, OS%MSp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) @@ -423,7 +426,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) endif call close_param_file(param_file) - call diag_mediator_close_registration(OS%MOM_CSp%diag) + call diag_mediator_close_registration(OS%diag) if (is_root_pe()) & write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' @@ -520,7 +523,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & weight = 1.0 if (OS%fluxes%fluxes_used) then - call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%MOM_CSp%diag) ! Needed to allow diagnostics in convert_IOB + call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%diag) ! Needed to allow diagnostics in convert_IOB call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%forces, OS%fluxes, index_bnds, OS%Time, & OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) @@ -577,7 +580,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%MOM_CSp%tracer_flow_CSp) endif - call disable_averaging(OS%MOM_CSp%diag) + call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time if(OS%MOM_Csp%offline_tracer_mode) then @@ -589,25 +592,25 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%Time = Master_time + Ocean_coupling_time_step OS%nstep = OS%nstep + 1 - call enable_averaging(time_step, OS%Time, OS%MOM_CSp%diag) + call enable_averaging(time_step, OS%Time, OS%diag) call mech_forcing_diags(OS%forces, OS%fluxes, time_step, OS%grid, & - OS%MOM_CSp%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%MOM_CSp%diag) + OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) if (OS%fluxes%fluxes_used) then - call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%MOM_CSp%diag) + call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%MOM_CSp%diag, OS%forcing_CSp%handles) + OS%grid, OS%diag, OS%forcing_CSp%handles) call accumulate_net_input(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & OS%grid, OS%sum_output_CSp) - call disable_averaging(OS%MOM_CSp%diag) + call disable_averaging(OS%diag) endif ! See if it is time to write out the energy. if (OS%energysave_geometric) then if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%geometric_end_time) .and. & - (OS%MOM_CSp%t_dyn_rel_adv==0.0)) then + (OS%MSp%t_dyn_rel_adv==0.0)) then call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) @@ -617,7 +620,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%write_energy_time) .and. & - (OS%MOM_CSp%t_dyn_rel_adv==0.0)) then + (OS%MSp%t_dyn_rel_adv==0.0)) then call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) @@ -756,7 +759,7 @@ subroutine ocean_model_restart(OS, timestamp) type(ocean_state_type), pointer :: OS character(len=*), intent(in), optional :: timestamp - if (OS%MOM_CSp%t_dyn_rel_adv > 0.0) call MOM_error(WARNING, "End of MOM_main reached "//& + if (OS%MSp%t_dyn_rel_adv > 0.0) call MOM_error(WARNING, "End of MOM_main reached "//& "with inconsistent dynamics and advective times. Additional restart fields "//& "that have not been coded yet would be required for reproducibility.") if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_restart "//& @@ -812,7 +815,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) ! (in) Time - The model time, used for writing restarts. call ocean_model_save_restart(Ocean_state, Time) - call diag_mediator_end(Time, Ocean_state%MOM_CSp%diag) + call diag_mediator_end(Time, Ocean_state%diag) call MOM_end(Ocean_state%MSp, Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) end subroutine ocean_model_end @@ -840,7 +843,7 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) ! restart behavior as now in FMS. character(len=200) :: restart_dir - if (OS%MOM_CSp%t_dyn_rel_adv > 0.0) call MOM_error(WARNING, "End of MOM_main reached "//& + if (OS%MSp%t_dyn_rel_adv > 0.0) call MOM_error(WARNING, "End of MOM_main reached "//& "with inconsistent dynamics and advective times. Additional restart fields "//& "that have not been coded yet would be required for reproducibility.") if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_save_restart "//& @@ -1040,7 +1043,7 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) call calculate_surface_state(OS%sfc_state, OS%MSp%u, & - OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%MSp%v, OS%MSp%h, OS%MSp%ave_ssh,& OS%grid, OS%GV, OS%MSp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 624b0c36e8..d5666b5509 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -333,6 +333,8 @@ module ocn_comp_mct type(MOM_state_type), pointer :: MSp => NULL() type(surface_forcing_CS), pointer :: forcing_CSp => NULL() type(sum_output_CS), pointer :: sum_output_CSp => NULL() + type(diag_ctrl), pointer :: & + diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type !> Control structure for this module @@ -827,10 +829,12 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, Time_in, & - offline_tracer_mode=offline_tracer_mode, input_restart_file=input_restart_file) + offline_tracer_mode=offline_tracer_mode, input_restart_file=input_restart_file, & + diag_ptr=OS%diag) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV OS%C_p = OS%MSp%tv%C_p OS%fluxes%C_p = OS%MSp%tv%C_p + use_temperature = ASSOCIATED(OS%MSp%tv%T) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -900,15 +904,15 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! Consider using a run-time flag to determine whether to do the diagnostic ! vertical integrals, since the related 3-d sums are not negligible in cost. - call allocate_surface_state(OS%state, OS%grid, OS%MOM_CSp%use_temperature, & + call allocate_surface_state(OS%state, OS%grid, use_temperature, & do_integrals=.true., gas_fields_ocn=gas_fields_ocn) - call surface_forcing_init(Time_in, OS%grid, param_file, OS%MOM_CSp%diag, & + call surface_forcing_init(Time_in, OS%grid, param_file, OS%diag, & OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%MOM_CSp%diag, OS%fluxes) + OS%diag, OS%fluxes) endif if (OS%icebergs_apply_rigid_boundary) then !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) @@ -929,25 +933,25 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (ASSOCIATED(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%MOM_CSp%diag, maskmap=OS%grid%Domain%maskmap, & + OS%diag, maskmap=OS%grid%Domain%maskmap, & gas_fields_ocn=gas_fields_ocn) else call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%MOM_CSp%diag, gas_fields_ocn=gas_fields_ocn) + OS%diag, gas_fields_ocn=gas_fields_ocn) endif ! This call can only occur here if the coupler_bc_type variables have been ! initialized already using the information from gas_fields_ocn. if (present(gas_fields_ocn)) then call calculate_surface_state(OS%state, OS%MSp%u, & - OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%MSp%v, OS%MSp%h, OS%MSp%ave_ssh,& OS%grid, OS%GV, OS%MSp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid) endif call close_param_file(param_file) - call diag_mediator_close_registration(OS%MOM_CSp%diag) + call diag_mediator_close_registration(OS%diag) if (is_root_pe()) & write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' @@ -970,7 +974,7 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) call calculate_surface_state(OS%state, OS%MSp%u, & - OS%MSp%v, OS%MSp%h, OS%MOM_CSp%ave_ssh,& + OS%MSp%v, OS%MSp%h, OS%MSp%ave_ssh,& OS%grid, OS%GV, OS%Msp, OS%MOM_CSp) call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid) @@ -1731,7 +1735,7 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & if (OS%fluxes%fluxes_used) then ! GMM, is enable_averaging needed now? - call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%MOM_CSp%diag) + call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%diag) call ocn_import(OS%fluxes, OS%Time, OS%grid, OS%forcing_CSp, OS%state, x2o_o, ind, sw_decomp, & c1, c2, c3, c4, OS%restore_salinity,OS%restore_temp) #ifdef _USE_GENERIC_TRACER @@ -1784,7 +1788,7 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & OS%MOM_CSp%tracer_flow_CSp) endif - call disable_averaging(OS%MOM_CSp%diag) + call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time if(OS%MOM_Csp%offline_tracer_mode) then @@ -1796,23 +1800,23 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & OS%Time = Master_time + Ocean_coupling_time_step OS%nstep = OS%nstep + 1 - call enable_averaging(time_step, OS%Time, OS%MOM_CSp%diag) + call enable_averaging(time_step, OS%Time, OS%diag) call mech_forcing_diags(OS%fluxes, time_step, OS%grid, & - OS%MOM_CSp%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%MOM_CSp%diag) + OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) if (OS%fluxes%fluxes_used) then - call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%MOM_CSp%diag) + call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) call forcing_diagnostics(OS%fluxes, OS%state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%MOM_CSp%diag, OS%forcing_CSp%handles) + OS%grid, OS%diag, OS%forcing_CSp%handles) call accumulate_net_input(OS%fluxes, OS%state, OS%fluxes%dt_buoy_accum, & OS%grid, OS%sum_output_CSp) - call disable_averaging(OS%MOM_CSp%diag) + call disable_averaging(OS%diag) endif ! See if it is time to write out the energy. if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%write_energy_time) .and. & - (OS%MOM_CSp%t_dyn_rel_adv==0.0)) then + (OS%MSp%t_dyn_rel_adv==0.0)) then call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & OS%MOM_CSp%tracer_flow_CSp) @@ -2454,7 +2458,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) !if (debug .and. is_root_pe()) write(glb%stdout,*)'Here 1' !GMM call save_restart(Ocean_state, Time) - call diag_mediator_end(Time, Ocean_state%MOM_CSp%diag) + call diag_mediator_end(Time, Ocean_state%diag) call MOM_end(Ocean_state%MSp, Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) !if (debug .and. is_root_pe()) write(glb%stdout,*)'Here 2' diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index f1faa40cd4..301f869fda 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -27,7 +27,7 @@ program MOM_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end + use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : calculate_surface_state, finish_MOM_initialization use MOM, only : MOM_state_type, step_offline @@ -160,6 +160,7 @@ program MOM_main logical :: unit_in_use integer :: initClock, mainClock, termClock + logical :: debug ! If true, write verbose checksums for debugging purposes. logical :: offline_tracer_mode ! If false, use the model in prognostic mode where ! the barotropic and baroclinic dynamics, thermodynamics, ! etc. are stepped forward integrated in time. @@ -174,6 +175,8 @@ program MOM_main type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() + type(diag_ctrl), pointer :: & + diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' @@ -280,12 +283,14 @@ program MOM_main segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time ! Note the not before CS%d - call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, segment_start_time, offline_tracer_mode = offline_tracer_mode) + call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, segment_start_time, & + offline_tracer_mode = offline_tracer_mode, diag_ptr=diag) else ! In this case, the segment starts at a time read from the MOM restart file ! or left as Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, offline_tracer_mode=offline_tracer_mode) + call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, & + offline_tracer_mode=offline_tracer_mode, diag_ptr=diag) endif fluxes%C_p = MSp%tv%C_p ! Copy the heat capacity for consistency. @@ -293,10 +298,10 @@ program MOM_main grid => MSp%G GV => MSp%GV call calculate_surface_state(sfc_state, MSp%u, MSp%v, MSp%h, & - MOM_CSp%ave_ssh, grid, GV, MSp, MOM_CSp) + MSp%ave_ssh, grid, GV, MSp, MOM_CSp) - call surface_forcing_init(Time, grid, param_file, MOM_CSp%diag, & + call surface_forcing_init(Time, grid, param_file, diag, & surface_forcing_CSp, MOM_CSp%tracer_flow_CSp) call callTree_waypoint("done surface_forcing_init") @@ -306,7 +311,7 @@ program MOM_main ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf call initialize_ice_shelf(param_file, grid, Time, ice_shelf_CSp, & - MOM_CSp%diag, forces, fluxes) + diag, forces, fluxes) endif call MOM_sum_output_init(grid, param_file, dirs%output_directory, & @@ -380,12 +385,14 @@ program MOM_main "The interval in units of TIMEUNIT between saves of the \n"//& "energies of the run and other globally summed diagnostics.", & default=set_time(int(time_step+0.5)), timeunit=Time_unit) + call get_param(param_file, "MOM", "DEBUG", debug, & + "If true, write out verbose debugging data.", default=.false.) call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) ! Close the param_file. No further parsing of input is possible after this. call close_param_file(param_file) - call diag_mediator_close_registration(MOM_CSp%diag) + call diag_mediator_close_registration(diag) ! Write out a time stamp file. if (calendar_type /= NO_CALENDAR) then @@ -434,7 +441,7 @@ program MOM_main call set_forcing(sfc_state, forces, fluxes, Time, Time_step_ocean, grid, & surface_forcing_CSp) endif - if (MOM_CSp%debug) then + if (debug) then call MOM_mech_forcing_chksum("After set forcing", forces, grid, haloshift=0) call MOM_forcing_chksum("After set forcing", fluxes, grid, haloshift=0) endif @@ -484,18 +491,18 @@ program MOM_main endif Time = Master_Time - call enable_averaging(time_step, Time, MOM_CSp%diag) - call mech_forcing_diags(forces, fluxes, time_step, grid, MOM_CSp%diag, & + call enable_averaging(time_step, Time, diag) + call mech_forcing_diags(forces, fluxes, time_step, grid, diag, & surface_forcing_CSp%handles) - call disable_averaging(MOM_CSp%diag) + call disable_averaging(diag) if (.not. offline_tracer_mode) then if (fluxes%fluxes_used) then - call enable_averaging(fluxes%dt_buoy_accum, Time, MOM_CSp%diag) + call enable_averaging(fluxes%dt_buoy_accum, Time, diag) call forcing_diagnostics(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, & - MOM_CSp%diag, surface_forcing_CSp%handles) + diag, surface_forcing_CSp%handles) call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, sum_output_CSp) - call disable_averaging(MOM_CSp%diag) + call disable_averaging(diag) else call MOM_error(FATAL, "The solo MOM_driver is not yet set up to handle "//& "thermodynamic time steps that are longer than the coupling timestep.") @@ -504,7 +511,7 @@ program MOM_main ! See if it is time to write out the energy. if ((Time + (Time_step_ocean/2) > write_energy_time) .and. & - (MOM_CSp%t_dyn_rel_adv == 0.0)) then + (MSp%t_dyn_rel_adv == 0.0)) then call write_energy(MSp%u, MSp%v, MSp%h, & MSp%tv, Time, n+ntstep-1, grid, GV, sum_output_CSp, & MOM_CSp%tracer_flow_CSp) @@ -541,7 +548,7 @@ program MOM_main call cpu_clock_end(mainClock) call cpu_clock_begin(termClock) if (Restart_control>=0) then - if (MOM_CSp%t_dyn_rel_adv > 0.0) call MOM_error(WARNING, "End of MOM_main reached "//& + if (MSp%t_dyn_rel_adv > 0.0) call MOM_error(WARNING, "End of MOM_main reached "//& "with inconsistent dynamics and advective times. Additional restart fields "//& "that have not been coded yet would be required for reproducibility.") if (.not.fluxes%fluxes_used .and. .not.offline_tracer_mode) call MOM_error(FATAL, & @@ -583,7 +590,7 @@ program MOM_main endif call callTree_waypoint("End MOM_main") - call diag_mediator_end(Time, MOM_CSp%diag, end_diag_manager=.true.) + call diag_mediator_end(Time, diag, end_diag_manager=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a8202877df..6048dc4336 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -176,11 +176,18 @@ module MOM v, & !< meridional velocity (m/s) vh, & !< vh = v * h * dx at v grid points (m3/s or kg/s) vhtr !< accumulated meridional thickness fluxes to advect tracers (m3 or kg) + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + ave_ssh !< time-averaged (ave over baroclinic time steps) sea surface height (meter) type(ocean_grid_type) :: G !< structure containing metrics and grid info type(verticalGrid_type), pointer :: GV => NULL() !< structure containing vertical grid info type(thermo_var_ptrs) :: tv !< structure containing pointers to available !! thermodynamic fields + real :: t_dyn_rel_adv !< The time of the dynamics relative to tracer + !! advection and lateral mixing (in seconds), or + !! equivalently the elapsed time since advectively + !! updating the tracers. t_dyn_rel_adv is invariably + !! positive and may span multiple coupling timesteps. end type MOM_state_type @@ -195,8 +202,6 @@ module MOM !! for derived diagnostics (e.g., energy budgets) type(cont_diag_ptrs) :: CDp !< structure containing pointers continuity equation !! terms, for derived diagnostics (e.g., energy budgets) - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - ave_ssh !< time-averaged (ave over baroclinic time steps) sea surface height (meter) real, pointer, dimension(:,:) :: Hml => NULL() !< active mixed layer depth, in m real, pointer, dimension(:,:,:) :: & u_prev => NULL(), & !< previous value of u stored for diagnostics @@ -238,11 +243,6 @@ module MOM real :: dt_therm !< thermodynamics time step (seconds) logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. - real :: t_dyn_rel_adv !< The time of the dynamics relative to tracer - !! advection and lateral mixing (in seconds), or - !! equivalently the elapsed time since advectively - !! updating the tracers. t_dyn_rel_adv is invariably - !! positive and may span multiple coupling timesteps. real :: t_dyn_rel_thermo !< The time of the dynamics relative to diabatic !! processes and remapping (in seconds). t_dyn_rel_thermo !! can be negative or positive depending on whether @@ -541,7 +541,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS CS%rel_time = 0.0 tot_wt_ssh = 0.0 - do j=js,je ; do i=is,ie ; CS%ave_ssh(i,j) = 0.0 ; ssh(i,j) = CS%missing; enddo ; enddo + do j=js,je ; do i=is,ie ; MS%ave_ssh(i,j) = 0.0 ; ssh(i,j) = CS%missing; enddo ; enddo if (associated(CS%VarMix)) then call enable_averaging(time_interval, Time_start+set_time(int(time_interval)), & @@ -588,7 +588,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS !=========================================================================== ! This is the first place where the diabatic processes and remapping could occur. - if (CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0)) then ! do thermodynamics. + if (CS%diabatic_first .and. (MS%t_dyn_rel_adv==0.0)) then ! do thermodynamics. if (thermo_does_span_coupling) then dtdia = dt_therm @@ -614,7 +614,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS CS%t_dyn_rel_thermo = -dtdia if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") - endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" + endif ! end of block "(CS%diabatic_first .and. (MS%t_dyn_rel_adv==0.0))" !=========================================================================== ! This is the start of the dynamics stepping part of the algorithm. @@ -622,7 +622,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS call cpu_clock_begin(id_clock_dynamics) call disable_averaging(CS%diag) - if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then + if ((MS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then if (thermo_does_span_coupling) then dtth = dt_therm else @@ -648,11 +648,11 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS ! The bottom boundary layer properties are out-of-date and need to be ! recalculated. This always occurs at the start of a coupling time ! step because the externally prescribed stresses may have changed. - do_calc_bbl = ((CS%t_dyn_rel_adv == 0.0) .or. (n==1)) + do_calc_bbl = ((MS%t_dyn_rel_adv == 0.0) .or. (n==1)) if (do_calc_bbl) then ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) - bbl_time_int = max(dt, min(dt_therm - CS%t_dyn_rel_adv, dt*(1+n_max-n)) ) + bbl_time_int = max(dt, min(dt_therm - MS%t_dyn_rel_adv, dt*(1+n_max-n)) ) call enable_averaging(bbl_time_int, & Time_local+set_time(int(bbl_time_int-dt+0.5)), CS%diag) call set_viscous_BBL(u, v, h, MS%tv, CS%visc, G, GV, CS%set_visc_CSp) @@ -798,7 +798,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS call disable_averaging(CS%diag) ! Advance the dynamics time by dt. - CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt + MS%t_dyn_rel_adv = MS%t_dyn_rel_adv + dt CS%t_dyn_rel_thermo = CS%t_dyn_rel_thermo + dt CS%t_dyn_rel_diag = CS%t_dyn_rel_diag + dt @@ -808,7 +808,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS ! This is the start of the tracer advection part of the algorithm. if (thermo_does_span_coupling) then - do_advection = (CS%t_dyn_rel_adv + 0.5*dt > dt_therm) + do_advection = (MS%t_dyn_rel_adv + 0.5*dt > dt_therm) else do_advection = ((MOD(n,ntstep) == 0) .or. (n==n_max)) endif @@ -820,7 +820,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS !=========================================================================== ! This is the second place where the diabatic processes and remapping could occur. - if (CS%t_dyn_rel_adv == 0.0) then + if (MS%t_dyn_rel_adv == 0.0) then if (.not.CS%diabatic_first) then dtdia = CS%t_dyn_rel_thermo if (thermo_does_span_coupling .and. (abs(dt_therm - dtdia) > 1e-6*dt_therm)) then @@ -845,7 +845,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS tot_wt_ssh = tot_wt_ssh + dt call find_eta(h, MS%tv, GV%g_Earth, G, GV, ssh, eta_av) do j=js,je ; do i=is,ie - CS%ave_ssh(i,j) = CS%ave_ssh(i,j) + dt*ssh(i,j) + MS%ave_ssh(i,j) = MS%ave_ssh(i,j) + dt*ssh(i,j) enddo ; enddo call cpu_clock_end(id_clock_dynamics) @@ -861,7 +861,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS if (IDs%id_ssh_inst > 0) call post_data(IDs%id_ssh_inst, ssh, CS%diag) call disable_averaging(CS%diag) - if (CS%t_dyn_rel_adv == 0.0) then + if (MS%t_dyn_rel_adv == 0.0) then ! Diagnostics that require the complete state to be up-to-date can be calculated. call enable_averaging(CS%t_dyn_rel_diag, Time_local, CS%diag) @@ -894,17 +894,17 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS Itot_wt_ssh = 1.0/tot_wt_ssh do j=js,je ; do i=is,ie - CS%ave_ssh(i,j) = CS%ave_ssh(i,j)*Itot_wt_ssh - ssh(i,j) = CS%ave_ssh(i,j) + MS%ave_ssh(i,j) = MS%ave_ssh(i,j)*Itot_wt_ssh + ssh(i,j) = MS%ave_ssh(i,j) enddo ; enddo - call adjust_ssh_for_p_atm(MS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) + call adjust_ssh_for_p_atm(MS%tv, G, GV, MS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) if (CS%interp_p_surf) then ; do j=jsd,jed ; do i=isd,ied CS%p_surf_prev(i,j) = forces%p_surf(i,j) enddo ; enddo ; endif if (showCallTree) call callTree_waypoint("calling calculate_surface_state (step_MOM)") - call calculate_surface_state(sfc_state, u, v, h, CS%ave_ssh, G, GV, MS, CS) + call calculate_surface_state(sfc_state, u, v, h, MS%ave_ssh, G, GV, MS, CS) ! Do diagnostics that only occur at the end of a complete forcing step. call cpu_clock_begin(id_clock_diagnostics) @@ -959,18 +959,18 @@ subroutine step_MOM_tracer_dyn(MS, CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn endif call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) - call enable_averaging(CS%t_dyn_rel_adv, Time_local, CS%diag) + call enable_averaging(MS%t_dyn_rel_adv, Time_local, CS%diag) - call advect_tracer(h, MS%uhtr, MS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, & + call advect_tracer(h, MS%uhtr, MS%vhtr, CS%OBC, MS%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, MS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, & CS%tracer_diff_CSp, CS%tracer_Reg, MS%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) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) call post_transport_diagnostics(G, GV, MS%uhtr, MS%vhtr, h, CS%transport_IDs, & - CS%diag, CS%t_dyn_rel_adv, CS%diag_to_Z_CSp, h_pre_dyn, T_pre_dyn, S_pre_dyn) + CS%diag, MS%t_dyn_rel_adv, CS%diag_to_Z_CSp, h_pre_dyn, T_pre_dyn, S_pre_dyn) ! Rebuild the remap grids now that we've posted the fields which rely on thicknesses ! from before the dynamics calls call diag_update_remap_grids(CS%diag) @@ -983,7 +983,7 @@ subroutine step_MOM_tracer_dyn(MS, CS, G, GV, h, h_pre_dyn, T_pre_dyn, S_pre_dyn call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) MS%uhtr(:,:,:) = 0.0 MS%vhtr(:,:,:) = 0.0 - CS%t_dyn_rel_adv = 0.0 + MS%t_dyn_rel_adv = 0.0 call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) if (CS%diabatic_first .and. CS%use_temperature) then @@ -1338,8 +1338,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, MS endif - call adjust_ssh_for_p_atm(MS%tv, G, GV, CS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) - call calculate_surface_state(sfc_state, MS%u, MS%v, MS%h, CS%ave_ssh, G, GV, MS, CS) + call adjust_ssh_for_p_atm(MS%tv, G, GV, MS%ave_ssh, forces%p_surf_SSH, CS%calc_rho_for_sea_lev) + call calculate_surface_state(sfc_state, MS%u, MS%v, MS%h, MS%ave_ssh, G, GV, MS, CS) call disable_averaging(CS%diag) call pass_var(MS%tv%T,G%Domain) @@ -1353,7 +1353,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, MS end subroutine step_offline !> This subroutine initializes MOM. -subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, offline_tracer_mode, input_restart_file) +subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & + offline_tracer_mode, input_restart_file, diag_ptr) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(param_file_type), intent(out) :: param_file !< structure indicating paramater file to parse type(directories), intent(out) :: dirs !< structure with directory paths @@ -1363,6 +1364,8 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, offline_trace !! model is not being started from a restart file logical, optional, intent(out) :: offline_tracer_mode !< True if tracers are being run offline character(len=*),optional, intent(in) :: input_restart_file !< If present, name of restart file to read + type(diag_ctrl), optional, pointer :: diag_ptr !< A pointer set in this routine to the diagnostic + !! regulatory structure ! local type(ocean_grid_type), pointer :: G => NULL() ! A pointer to a structure with metrics and related @@ -1873,7 +1876,7 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, offline_trace ALLOC_(MS%uhtr(IsdB:IedB,jsd:jed,nz)) ; MS%uhtr(:,:,:) = 0.0 ALLOC_(MS%vhtr(isd:ied,JsdB:JedB,nz)) ; MS%vhtr(:,:,:) = 0.0 - CS%t_dyn_rel_adv = 0.0 ; CS%t_dyn_rel_thermo = 0.0 ; CS%t_dyn_rel_diag = 0.0 + MS%t_dyn_rel_adv = 0.0 ; CS%t_dyn_rel_thermo = 0.0 ; CS%t_dyn_rel_diag = 0.0 if (CS%debug_truncations) then allocate(CS%u_prev(IsdB:IedB,jsd:jed,nz)) ; CS%u_prev(:,:,:) = 0.0 @@ -1899,7 +1902,7 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, offline_trace allocate(CS%p_surf_prev(isd:ied,jsd:jed)) ; CS%p_surf_prev(:,:) = 0.0 endif - ALLOC_(CS%ave_ssh(isd:ied,jsd:jed)) ; CS%ave_ssh(:,:) = 0.0 + ALLOC_(MS%ave_ssh(isd:ied,jsd:jed)) ; MS%ave_ssh(:,:) = 0.0 ! Use the Wright equation of state by default, unless otherwise specified ! Note: this line and the following block ought to be in a separate @@ -2061,6 +2064,7 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, offline_trace diag => CS%diag ! Initialize the diag mediator. call diag_mediator_init(G, GV, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + if (present(diag_ptr)) diag_ptr => CS%diag ! Initialize the diagnostics masks for native arrays. ! This step has to be done after call to MOM_initialize_state @@ -2228,11 +2232,11 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, offline_trace if (CS%p_surf_prev_set) call pass_var(CS%p_surf_prev, G%domain) endif - if (.not.query_initialized(CS%ave_ssh,"ave_ssh",CS%restart_CSp)) then + if (.not.query_initialized(MS%ave_ssh,"ave_ssh",CS%restart_CSp)) then if (CS%split) then - call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, CS%ave_ssh, eta) + call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, MS%ave_ssh, eta) else - call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, CS%ave_ssh) + call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, MS%ave_ssh) endif endif if (CS%split) deallocate(eta) @@ -2691,7 +2695,7 @@ subroutine set_restart_fields(GV, param_file, MS, CS) "Previous ocean surface pressure", "Pa") endif - call register_restart_field(CS%ave_ssh, "ave_ssh", .false., CS%restart_CSp, & + call register_restart_field(MS%ave_ssh, "ave_ssh", .false., CS%restart_CSp, & "Time average sea surface height", "meter") ! hML is needed when using the ice shelf module @@ -3123,7 +3127,7 @@ subroutine MOM_end(MS, CS) else call end_dyn_unsplit(CS%dyn_unsplit_CSp) endif - DEALLOC_(CS%ave_ssh) + DEALLOC_(MS%ave_ssh) if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) call verticalGridEnd(MS%GV) From a1bcc6fe92f36ddb072a3a2c21434e33daaaed04 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 25 Jan 2018 10:27:58 -0500 Subject: [PATCH 150/170] +Moved restart_CS up to the driver level Moved the primary location of the restart_CS out of the MOM control structure and into the top-level MOM driver, since that is the level where it is actually used. This changes the interface to initialize_MOM and it changes the elements of several control structures. All solutions are bitwise identical. --- config_src/coupled_driver/ocean_model_MOM.F90 | 19 ++-- .../ice_solo_driver/ice_shelf_driver.F90 | 4 +- config_src/mct_driver/ocn_comp_mct.F90 | 14 +-- config_src/solo_driver/MOM_driver.F90 | 20 +++-- src/core/MOM.F90 | 86 ++++++++++--------- 5 files changed, 80 insertions(+), 63 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 9ef1691806..d6fb9b7f57 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -35,7 +35,7 @@ module ocean_model_mod use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number -use MOM_restart, only : save_restart +use MOM_restart, only : MOM_restart_CS, save_restart use MOM_sum_output, only : write_energy, accumulate_net_input use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS use MOM_string_functions, only : uppercase @@ -208,6 +208,9 @@ module ocean_model_mod forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(sum_output_CS), pointer :: & sum_output_CSp => NULL() !< A pointer to the MOM sum output control structure + type(MOM_restart_CS), pointer :: & + restart_CSp => NULL() !< A pointer set to the restart control structure + !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -275,8 +278,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) if (.not.OS%is_ocean_pe) return OS%Time = Time_in - call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, Time_in, & - offline_tracer_mode=offline_tracer_mode, diag_ptr=OS%diag) + call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, OS%restart_CSp, & + Time_in, offline_tracer_mode=offline_tracer_mode, & + diag_ptr=OS%diag) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV OS%C_p = OS%MSp%tv%C_p OS%fluxes%C_p = OS%MSp%tv%C_p @@ -573,7 +577,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes, & + OS%restart_CSp) call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, & @@ -768,7 +773,7 @@ subroutine ocean_model_restart(OS, timestamp) if (BTEST(OS%Restart_control,1)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%MOM_CSp%restart_CSp, .true., GV=OS%GV) + OS%restart_CSp, .true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -777,7 +782,7 @@ subroutine ocean_model_restart(OS, timestamp) endif if (BTEST(OS%Restart_control,0)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%MOM_CSp%restart_CSp, GV=OS%GV) + OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -853,7 +858,7 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%MOM_CSp%restart_CSp, GV=OS%GV) + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index f879807916..628b138639 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -283,8 +283,6 @@ program SHELF_main call log_param(param_file, mdl, "ELAPSED TIME AS MASTER", elapsed_time_master) ! i don't think we'll use this... -! call MOM_sum_output_init(grid, param_file, dirs%output_directory, & -! MOM_CSp%ntrunc, Start_time, sum_output_CSp) call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & write_CPU_CSp) call MOM_mesg("Done MOM_write_cputime_init.", 5) @@ -292,7 +290,7 @@ program SHELF_main ! Close the param_file. No further parsing of input is possible after this. call close_param_file(param_file) - call diag_mediator_close_registration(MOM_CSp%diag) +! call diag_mediator_close_registration(diag) ! Write out a time stamp file. call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index d5666b5509..4638593593 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -333,6 +333,9 @@ module ocn_comp_mct type(MOM_state_type), pointer :: MSp => NULL() type(surface_forcing_CS), pointer :: forcing_CSp => NULL() type(sum_output_CS), pointer :: sum_output_CSp => NULL() + type(MOM_restart_CS), pointer :: & + restart_CSp => NULL() !< A pointer set to the restart control structure + !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -828,9 +831,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (.not.OS%is_ocean_pe) return OS%Time = Time_in - call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, Time_in, & - offline_tracer_mode=offline_tracer_mode, input_restart_file=input_restart_file, & - diag_ptr=OS%diag) + call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, & + OS%restart_CSp, Time_in, offline_tracer_mode=offline_tracer_mode, & + input_restart_file=input_restart_file, diag_ptr=OS%diag) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV OS%C_p = OS%MSp%tv%C_p OS%fluxes%C_p = OS%MSp%tv%C_p @@ -1626,7 +1629,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%MOM_CSp%restart_CSp, .false., filename=restartname,GV=glb%ocn_state%GV) + glb%ocn_state%restart_CSp, .false., filename=restartname,GV=glb%ocn_state%GV) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -1781,7 +1784,8 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes, & + OS%restart_CSp) call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, & diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 301f869fda..1975d8ec8d 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -43,7 +43,7 @@ program MOM_main use MOM_io, only : file_exists, open_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_restart, only : save_restart + use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions,only : uppercase use MOM_sum_output, only : write_energy, accumulate_net_input use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS @@ -175,6 +175,9 @@ program MOM_main type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() + type(MOM_restart_CS), pointer :: & + restart_CSp => NULL() !< A pointer set to the restart control structure + !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- @@ -283,13 +286,14 @@ program MOM_main segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time ! Note the not before CS%d - call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, segment_start_time, & - offline_tracer_mode = offline_tracer_mode, diag_ptr=diag) + call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & + segment_start_time, offline_tracer_mode=offline_tracer_mode, & + diag_ptr=diag) else ! In this case, the segment starts at a time read from the MOM restart file ! or left as Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, & + call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & offline_tracer_mode=offline_tracer_mode, diag_ptr=diag) endif fluxes%C_p = MSp%tv%C_p ! Copy the heat capacity for consistency. @@ -456,7 +460,7 @@ program MOM_main fluxes%dt_buoy_accum = time_step if (n==1) then - call finish_MOM_initialization(Time, dirs, MSp, MOM_CSp, fluxes) + call finish_MOM_initialization(Time, dirs, MSp, MOM_CSp, fluxes, restart_CSp) call write_energy(MSp%u, MSp%v, MSp%h, MSp%tv, & Time, 0, grid, GV, sum_output_CSp, MOM_CSp%tracer_flow_CSp, & @@ -524,7 +528,7 @@ program MOM_main (Time + (Time_step_ocean/2) > restart_time)) then if (BTEST(Restart_control,1)) then call save_restart(dirs%restart_output_dir, Time, grid, & - MOM_CSp%restart_CSp, .true., GV=GV) + restart_CSp, .true., GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & @@ -532,7 +536,7 @@ program MOM_main endif if (BTEST(Restart_control,0)) then call save_restart(dirs%restart_output_dir, Time, grid, & - MOM_CSp%restart_CSp, GV=GV) + restart_CSp, GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & @@ -556,7 +560,7 @@ program MOM_main "For conservation, the ocean restart files can only be "//& "created after the buoyancy forcing is applied.") - call save_restart(dirs%restart_output_dir, Time, grid, MOM_CSp%restart_CSp, GV=GV) + call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) ! Write ocean solo restart file. diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 6048dc4336..d061789f4a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -320,7 +320,6 @@ module MOM type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() type(diagnostics_CS), pointer :: diagnostics_CSp => NULL() type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() type(ocean_OBC_type), pointer :: OBC => NULL() type(sponge_CS), pointer :: sponge_CSp => NULL() @@ -1353,13 +1352,16 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, MS end subroutine step_offline !> This subroutine initializes MOM. -subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & +subroutine initialize_MOM(Time, param_file, dirs, MS, CS, restart_CSp, Time_in, & offline_tracer_mode, input_restart_file, diag_ptr) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(param_file_type), intent(out) :: param_file !< structure indicating paramater file to parse type(directories), intent(out) :: dirs !< structure with directory paths type(MOM_state_type), pointer :: MS !< pointer set in this routine to structure describing the MOM state type(MOM_control_struct), pointer :: CS !< pointer set in this routine to MOM control structure + type(MOM_restart_CS), pointer :: restart_CSp !< pointer set in this routine to the + !! restart control structure that will + !! be used for MOM. type(time_type), optional, intent(in) :: Time_in !< time passed to MOM_initialize_state when !! model is not being started from a restart file logical, optional, intent(out) :: offline_tracer_mode !< True if tracers are being run offline @@ -1720,7 +1722,7 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & ((dirs%input_filename(1:1)=='n') .and. (LEN_TRIM(dirs%input_filename)==1)))) ! If the restart file type had been initialized, this could become: ! write_geom_files = ((write_geom==2) .or. & -! ((write_geom==1) .and. is_new_run(CS%restart_CSp))) +! ((write_geom==1) .and. is_new_run(restart_CSp))) ! Check for inconsistent parameter settings. if (CS%use_ALE_algorithm .and. CS%bulkmixedlayer) call MOM_error(FATAL, & @@ -1920,30 +1922,30 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & ! Set the fields that are needed for bitwise identical restarting ! the time stepping scheme. - call restart_init(param_file, CS%restart_CSp) - call set_restart_fields(GV, param_file, MS, CS) + call restart_init(param_file, restart_CSp) + call set_restart_fields(GV, param_file, MS, CS, restart_CSp) if (CS%split) then call register_restarts_dyn_split_RK2(dG%HI, GV, param_file, & - CS%dyn_split_RK2_CSp, CS%restart_CSp, MS%uh, MS%vh) + CS%dyn_split_RK2_CSp, restart_CSp, MS%uh, MS%vh) elseif (CS%use_RK2) then call register_restarts_dyn_unsplit_RK2(dG%HI, GV, param_file, & - CS%dyn_unsplit_RK2_CSp, CS%restart_CSp) + CS%dyn_unsplit_RK2_CSp, restart_CSp) else call register_restarts_dyn_unsplit(dG%HI, GV, param_file, & - CS%dyn_unsplit_CSp, CS%restart_CSp) + CS%dyn_unsplit_CSp, restart_CSp) endif ! This subroutine calls user-specified tracer registration routines. ! Additional calls can be added to MOM_tracer_flow_control.F90. call call_tracer_register(dG%HI, GV, param_file, CS%tracer_flow_CSp, & - CS%tracer_Reg, CS%restart_CSp) + CS%tracer_Reg, restart_CSp) - call MEKE_alloc_register_restart(dG%HI, param_file, CS%MEKE, CS%restart_CSp) - call set_visc_register_restarts(dG%HI, GV, param_file, CS%visc, CS%restart_CSp) - call mixedlayer_restrat_register_restarts(dG%HI, param_file, CS%mixedlayer_restrat_CSp, CS%restart_CSp) + call MEKE_alloc_register_restart(dG%HI, param_file, CS%MEKE, restart_CSp) + call set_visc_register_restarts(dG%HI, GV, param_file, CS%visc, restart_CSp) + call mixedlayer_restrat_register_restarts(dG%HI, param_file, CS%mixedlayer_restrat_CSp, restart_CSp) if (associated(CS%OBC)) & - call open_boundary_register_restarts(dg%HI, GV, CS%OBC, CS%restart_CSp) + call open_boundary_register_restarts(dg%HI, GV, CS%OBC, restart_CSp) call callTree_waypoint("restart registration complete (initialize_MOM)") @@ -1976,7 +1978,7 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & G%ke = GV%ke ; G%g_Earth = GV%g_Earth call MOM_initialize_state(MS%u, MS%v, MS%h, MS%tv, Time, G, GV, param_file, & - dirs, CS%restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & + dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & CS%sponge_CSp, CS%ALE_sponge_CSp, CS%OBC, Time_in) call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") @@ -2009,7 +2011,7 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & ! remainder of this subroutine is controlled by the parameters that have ! have already been set. - if (ALE_remap_init_conds(CS%ALE_CSp) .and. .not. query_initialized(MS%h,"h",CS%restart_CSp)) then + if (ALE_remap_init_conds(CS%ALE_CSp) .and. .not. query_initialized(MS%h,"h",restart_CSp)) then ! This block is controlled by the ALE parameter REMAP_AFTER_INITIALIZATION. ! \todo This block exists for legacy reasons and we should phase it out of ! all examples. !### @@ -2104,25 +2106,25 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("ALE initialized (initialize_MOM)") - CS%useMEKE = MEKE_init(Time, G, param_file, diag, CS%MEKE_CSp, CS%MEKE, CS%restart_CSp) + CS%useMEKE = MEKE_init(Time, G, param_file, diag, CS%MEKE_CSp, CS%MEKE, restart_CSp) call VarMix_init(Time, G, param_file, diag, CS%VarMix) call set_visc_init(Time, G, GV, param_file, diag, CS%visc, CS%set_visc_CSp,CS%OBC) if (CS%split) then allocate(eta(SZI_(G),SZJ_(G))) ; eta(:,:) = 0.0 call initialize_dyn_split_RK2(MS%u, MS%v, MS%h, MS%uh, MS%vh, eta, Time, & - G, GV, param_file, diag, CS%dyn_split_RK2_CSp, CS%restart_CSp, & + G, GV, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc) elseif (CS%use_RK2) then call initialize_dyn_unsplit_RK2(MS%u, MS%v, MS%h, Time, G, GV, & - param_file, diag, CS%dyn_unsplit_RK2_CSp, CS%restart_CSp, & + param_file, diag, CS%dyn_unsplit_RK2_CSp, restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, CS%update_OBC_CSp, & CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, CS%ntrunc) else call initialize_dyn_unsplit(MS%u, MS%v, MS%h, Time, G, GV, & - param_file, diag, CS%dyn_unsplit_CSp, CS%restart_CSp, & + param_file, diag, CS%dyn_unsplit_CSp, restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, CS%update_OBC_CSp, & CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, CS%ntrunc) endif @@ -2180,7 +2182,7 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & endif ! This subroutine initializes any tracer packages. - new_sim = is_new_run(CS%restart_CSp) + new_sim = is_new_run(restart_CSp) call tracer_flow_control_init(.not.new_sim, Time, G, GV, MS%h, param_file, & CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & CS%ALE_sponge_CSp, CS%diag_to_Z_CSp, MS%tv) @@ -2221,18 +2223,18 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & call neutral_diffusion_diag_init(Time, G, diag, MS%tv%C_p, CS%tracer_Reg, CS%neutral_diffusion_CSp) if (CS%use_frazil) then - if (.not.query_initialized(MS%tv%frazil,"frazil",CS%restart_CSp)) & + if (.not.query_initialized(MS%tv%frazil,"frazil",restart_CSp)) & MS%tv%frazil(:,:) = 0.0 endif if (CS%interp_p_surf) then CS%p_surf_prev_set = & - query_initialized(CS%p_surf_prev,"p_surf_prev",CS%restart_CSp) + query_initialized(CS%p_surf_prev,"p_surf_prev",restart_CSp) if (CS%p_surf_prev_set) call pass_var(CS%p_surf_prev, G%domain) endif - if (.not.query_initialized(MS%ave_ssh,"ave_ssh",CS%restart_CSp)) then + if (.not.query_initialized(MS%ave_ssh,"ave_ssh",restart_CSp)) then if (CS%split) then call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, MS%ave_ssh, eta) else @@ -2252,12 +2254,14 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, Time_in, & end subroutine initialize_MOM !> This subroutine finishes initializing MOM and writes out the initial conditions. -subroutine finish_MOM_initialization(Time, dirs, MS, CS, fluxes) - type(time_type), intent(in) :: Time !< model time, used in this routine - type(directories), intent(in) :: dirs !< structure with directory paths - type(MOM_state_type), pointer :: MS !< pointer to structure describing the MOM state - type(MOM_control_struct), pointer :: CS !< pointer to MOM control structure - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields +subroutine finish_MOM_initialization(Time, dirs, MS, CS, fluxes, restart_CSp) + type(time_type), intent(in) :: Time !< model time, used in this routine + type(directories), intent(in) :: dirs !< structure with directory paths + type(MOM_state_type), pointer :: MS !< pointer to structure describing the MOM state + type(MOM_control_struct), pointer :: CS !< pointer to MOM control structure + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control + !! structure that will be used for MOM. ! Local variables type(ocean_grid_type), pointer :: G => NULL() type(verticalGrid_type), pointer :: GV => NULL() @@ -2275,7 +2279,7 @@ subroutine finish_MOM_initialization(Time, dirs, MS, CS, fluxes) ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) - restart_CSp_tmp = CS%restart_CSp + restart_CSp_tmp = restart_CSp allocate(z_interface(SZI_(G),SZJ_(G),SZK_(G)+1)) call find_eta(MS%h, MS%tv, GV%g_Earth, G, GV, z_interface) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & @@ -2655,11 +2659,13 @@ end subroutine write_static_fields !! This routine should be altered if there are any changes to the !! time stepping scheme. The CHECK_RESTART facility may be used to !! confirm that all needed restart fields have been included. -subroutine set_restart_fields(GV, param_file, MS, CS) +subroutine set_restart_fields(GV, param_file, MS, CS, restart_CSp) type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure type(param_file_type), intent(in) :: param_file !< opened file for parsing to get parameters type(MOM_state_type), intent(in) :: MS !< structure describing the MOM state type(MOM_control_struct), intent(in) :: CS !< control structure set up by inialize_MOM + type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control + !! structure that will be used for MOM. ! Local variables logical :: use_ice_shelf ! Needed to determine whether to add CS%Hml to restarts character(len=48) :: thickness_units, flux_units @@ -2670,37 +2676,37 @@ subroutine set_restart_fields(GV, param_file, MS, CS) flux_units = get_flux_units(GV) if (CS%use_temperature) then - call register_restart_field(MS%tv%T, "Temp", .true., CS%restart_CSp, & + call register_restart_field(MS%tv%T, "Temp", .true., restart_CSp, & "Potential Temperature", "degC") - call register_restart_field(MS%tv%S, "Salt", .true., CS%restart_CSp, & + call register_restart_field(MS%tv%S, "Salt", .true., restart_CSp, & "Salinity", "PPT") endif - call register_restart_field(MS%h, "h", .true., CS%restart_CSp, & + call register_restart_field(MS%h, "h", .true., restart_CSp, & "Layer Thickness", thickness_units) - call register_restart_field(MS%u, "u", .true., CS%restart_CSp, & + call register_restart_field(MS%u, "u", .true., restart_CSp, & "Zonal velocity", "m s-1", hor_grid='Cu') - call register_restart_field(MS%v, "v", .true., CS%restart_CSp, & + call register_restart_field(MS%v, "v", .true., restart_CSp, & "Meridional velocity", "m s-1", hor_grid='Cv') if (CS%use_frazil) then - call register_restart_field(MS%tv%frazil, "frazil", .false., CS%restart_CSp, & + call register_restart_field(MS%tv%frazil, "frazil", .false., restart_CSp, & "Frazil heat flux into ocean", "J m-2") endif if (CS%interp_p_surf) then - call register_restart_field(CS%p_surf_prev, "p_surf_prev", .false., CS%restart_CSp, & + call register_restart_field(CS%p_surf_prev, "p_surf_prev", .false., restart_CSp, & "Previous ocean surface pressure", "Pa") endif - call register_restart_field(MS%ave_ssh, "ave_ssh", .false., CS%restart_CSp, & + call register_restart_field(MS%ave_ssh, "ave_ssh", .false., restart_CSp, & "Time average sea surface height", "meter") ! hML is needed when using the ice shelf module if (use_ice_shelf .and. associated(CS%Hml)) then - call register_restart_field(CS%Hml, "hML", .false., CS%restart_CSp, & + call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & "Mixed layer thickness", "meter") endif From 401f03844fc5218554ec3e668d7c7947964b7891 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 25 Jan 2018 11:53:21 -0800 Subject: [PATCH 151/170] Move loop over tracer registry into neutral diffusion module The loop over the tracer registry was originally at the level of tracer_hor_diff, but for organizational purposes it makes more sense for it to be in the neutral_diffusion subroutine. --- src/tracer/MOM_neutral_diffusion.F90 | 243 ++++++++++++++------------- src/tracer/MOM_tracer_hor_diff.F90 | 7 +- 2 files changed, 126 insertions(+), 124 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index e47049fe1e..7892dd333a 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -17,7 +17,7 @@ module MOM_neutral_diffusion 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 +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 @@ -477,16 +477,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) end subroutine neutral_diffusion_calc_coeffs !> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. -subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) +subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H units) real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points (m^2) real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at u-points (m^2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Tracer !< Tracer concentration - integer, intent(in) :: m !< Tracer number real, intent(in) :: dt !< Tracer time step * I_numitts (I_numitts in tracer_hordiff) - character(len=32), intent(in) :: name !< Tracer name + type(tracer_registry_type), pointer :: Reg !< Tracer registry type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables @@ -497,7 +495,10 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) real, dimension(SZIB_(G),SZJ_(G)) :: trans_x_2d ! depth integrated diffusive tracer x-transport diagn real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport diagn real, dimension(G%ke) :: dTracer ! change in tracer concentration due to ndiffusion - integer :: i, j, k, ks, nk + + type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer + + integer :: i, j, k, m, ks, nk real :: ppt2mks, Idt, convert real :: h_neglect, h_neglect_edge @@ -507,137 +508,141 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) nk = GV%ke - ! for diagnostics - if(CS%id_neutral_diff_tracer_conc_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0 .or. & - CS%id_neutral_diff_tracer_trans_x_2d(m) > 0 .or. & - CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then - ppt2mks = 0.001 - Idt = 1.0/dt - tendency(:,:,:) = 0.0 - tendency_2d(:,:) = 0.0 - trans_x_2d(:,:) = 0.0 - trans_y_2d(:,:) = 0.0 - convert = 1.0 - if(trim(name) == 'T') convert = CS%C_p * GV%H_to_kg_m2 - if(trim(name) == 'S') convert = ppt2mks * GV%H_to_kg_m2 - endif - - uFlx(:,:,:) = 0. - vFlx(:,:,:) = 0. - - ! x-flux - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i+1,j,:), & - Tracer(i,j,:), Tracer(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), & - CS%uKoL(I,j,:), CS%uKoR(I,j,:), & - CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + do m = 1,Reg%ntr ! Loop over tracer registry + + tracer => Reg%Tr(m) + + ! for diagnostics + if(CS%id_neutral_diff_tracer_conc_tend(m) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend(m) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0 .or. & + CS%id_neutral_diff_tracer_trans_x_2d(m) > 0 .or. & + CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then + ppt2mks = 0.001 + Idt = 1.0/dt + tendency(:,:,:) = 0.0 + tendency_2d(:,:) = 0.0 + trans_x_2d(:,:) = 0.0 + trans_y_2d(:,:) = 0.0 + convert = 1.0 + if(trim(tracer%name) == 'T') convert = CS%C_p * GV%H_to_kg_m2 + if(trim(tracer%name) == 'S') convert = ppt2mks * GV%H_to_kg_m2 endif - enddo ; enddo - ! y-flux - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i,j+1,:), & - Tracer(i,j,:), Tracer(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), & - CS%vKoL(i,J,:), CS%vKoR(i,J,:), & - CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) - endif - enddo ; enddo + uFlx(:,:,:) = 0. + vFlx(:,:,:) = 0. - ! Update the tracer concentration from divergence of neutral diffusive flux components - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - - dTracer(:) = 0. - do ks = 1,CS%nsurf-1 ; - k = CS%uKoL(I,j,ks) - dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) - k = CS%uKoR(I-1,j,ks) - dTracer(k) = dTracer(k) - Coef_x(I-1,j) * uFlx(I-1,j,ks) - k = CS%vKoL(i,J,ks) - dTracer(k) = dTracer(k) + Coef_y(i,J) * vFlx(i,J,ks) - k = CS%vKoR(i,J-1,ks) - dTracer(k) = dTracer(k) - Coef_y(i,J-1) * vFlx(i,J-1,ks) - enddo - do k = 1, GV%ke - Tracer(i,j,k) = Tracer(i,j,k) + dTracer(k) * & - ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) - enddo - - if(CS%id_neutral_diff_tracer_conc_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0 ) then - do k = 1, GV%ke - tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt - enddo - endif - - endif - enddo ; enddo - - - ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. - ! Note sign corresponds to downgradient flux convention. - if(CS%id_neutral_diff_tracer_trans_x_2d(m) > 0) then + ! x-flux do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - trans_x_2d(I,j) = 0. if (G%mask2dCu(I,j)>0.) then - do ks = 1,CS%nsurf-1 ; - trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) - enddo - trans_x_2d(I,j) = trans_x_2d(I,j) * Idt * convert + call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) endif enddo ; enddo - call post_data(CS%id_neutral_diff_tracer_trans_x_2d(m), trans_x_2d(:,:), CS%diag) - endif - ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. - ! Note sign corresponds to downgradient flux convention. - if(CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then + ! y-flux do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - trans_y_2d(i,J) = 0. if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%ppoly_deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + endif + enddo ; enddo + + ! Update the tracer concentration from divergence of neutral diffusive flux components + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + + dTracer(:) = 0. do ks = 1,CS%nsurf-1 ; - trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - Coef_x(I-1,j) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + Coef_y(i,J) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - Coef_y(i,J-1) * vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) enddo - trans_y_2d(i,J) = trans_y_2d(i,J) * Idt * convert + + if(CS%id_neutral_diff_tracer_conc_tend(m) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend(m) > 0 .or. & + CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif + endif enddo ; enddo - call post_data(CS%id_neutral_diff_tracer_trans_y_2d(m), trans_y_2d(:,:), CS%diag) - endif - ! post tendency of tracer content - if(CS%id_neutral_diff_tracer_cont_tend(m) > 0) then - call post_data(CS%id_neutral_diff_tracer_cont_tend(m), tendency(:,:,:)*convert, CS%diag) - endif - ! post depth summed tendency for tracer content - if(CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0) then - 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(CS%id_neutral_diff_tracer_cont_tend_2d(m), tendency_2d(:,:)*convert, CS%diag) - endif + ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. + ! Note sign corresponds to downgradient flux convention. + if(CS%id_neutral_diff_tracer_trans_x_2d(m) > 0) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + trans_x_2d(I,j) = 0. + if (G%mask2dCu(I,j)>0.) then + do ks = 1,CS%nsurf-1 ; + trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt * convert + endif + enddo ; enddo + call post_data(CS%id_neutral_diff_tracer_trans_x_2d(m), trans_x_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(CS%id_neutral_diff_tracer_conc_tend(m) > 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(CS%id_neutral_diff_tracer_conc_tend(m), tendency, CS%diag) - endif + ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. + ! Note sign corresponds to downgradient flux convention. + if(CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + trans_y_2d(i,J) = 0. + if (G%mask2dCv(i,J)>0.) then + do ks = 1,CS%nsurf-1 ; + trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt * convert + endif + enddo ; enddo + call post_data(CS%id_neutral_diff_tracer_trans_y_2d(m), trans_y_2d(:,:), CS%diag) + endif + + ! post tendency of tracer content + if(CS%id_neutral_diff_tracer_cont_tend(m) > 0) then + call post_data(CS%id_neutral_diff_tracer_cont_tend(m), tendency(:,:,:)*convert, CS%diag) + endif + + ! post depth summed tendency for tracer content + if(CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0) then + 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(CS%id_neutral_diff_tracer_cont_tend_2d(m), tendency_2d(:,:)*convert, 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(CS%id_neutral_diff_tracer_conc_tend(m) > 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(CS%id_neutral_diff_tracer_conc_tend(m), tendency, CS%diag) + endif + enddo ! Loop over tracer registry end subroutine neutral_diffusion diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index a09efe2b69..799ff0329c 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -92,7 +92,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla type(VarMix_CS), pointer :: VarMix !< Variable mixing type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(tracer_hor_diff_CS), pointer :: CS !< module control structure - type(tracer_registry_type), intent(inout) :: Reg !< registered tracers + type(tracer_registry_type), pointer :: Reg !< registered tracers type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available !! thermodynamic fields, including potential temp and !! salinity or mixed layer density. Absent fields have @@ -349,10 +349,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 - do m=1,ntr ! for each tracer - call neutral_diffusion(G, GV, h, Coef_x, Coef_y, Reg%Tr(m)%t, m, I_numitts*dt, & - Reg%Tr(m)%name, CS%neutral_diffusion_CSp) - enddo ! m + call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%neutral_diffusion_CSp) enddo ! itt else ! following if not using neutral diffusion, but instead along-surface diffusion From 9d4a7da62c5081ba90a41f522364c3079242c70f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 25 Jan 2018 17:29:34 -0500 Subject: [PATCH 152/170] Adapt restart checksum ranges for symmetric mode - Loop ranges used for checksums in restarts are now dependent on symmetric memory: the global west/south edge are included in the checksum. - Renamed get_MOM_compute_domain() to get_checksum_loop_ranges() for clarity. --- src/framework/MOM_restart.F90 | 110 +++++++++++++--------------------- 1 file changed, 42 insertions(+), 68 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index b8f3a73b9e..c77ade5506 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -836,7 +836,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs integer :: length integer(kind=8) :: check_val(CS%max_fields,1) - integer :: isL,ieL,jsL,jeL + integer :: isL, ieL, jsL, jeL, pos if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") @@ -932,13 +932,25 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) do m=start_var,next_var-1 vars(m-start_var+1) = CS%restart_field(m)%vars enddo - call query_vardesc(vars(1), t_grid=t_grid, caller="save_restart") + call query_vardesc(vars(1), t_grid=t_grid, hor_grid=hor_grid, caller="save_restart") t_grid = adjustl(t_grid) if (t_grid(1:1) /= 'p') & call modify_vardesc(vars(1), t_grid='s', caller="save_restart") + select case (hor_grid) + case ('q') ; pos = CORNER + case ('h') ; pos = CENTER + case ('u') ; pos = EAST_FACE + case ('v') ; pos = NORTH_FACE + case ('Bu') ; pos = CORNER + case ('T') ; pos = CENTER + case ('Cu') ; pos = EAST_FACE + case ('Cv') ; pos = NORTH_FACE + case ('1') ; pos = 0 + case default ; pos = 0 + end select !Prepare the checksum of the restart fields to be written to restart files - call get_MOM_compute_domain(G,isL,ieL,jsL,jeL) + call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) do m=start_var,next_var-1 if (ASSOCIATED(CS%var_ptr3d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) @@ -1125,7 +1137,7 @@ subroutine restore_state(filename, directory, day, G, CS) case default ; pos = 0 end select - call get_MOM_compute_domain(G,isL,ieL,jsL,jeL) + call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) do i=1, nvar call get_file_atts(fields(i),name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then @@ -1607,69 +1619,31 @@ subroutine restart_error(CS) endif end subroutine restart_error -subroutine get_MOM_compute_domain(G,isL,ieL,jsL,jeL) -! use mpp_domains_mod, only: mpp_get_domain_shift - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - integer , intent(out):: isL,ieL,jsL,jeL -! integer , intent(in) :: sizes(:),pos -! integer :: is0,js0 -! integer :: iadd,jadd,ishift, jshift, pos,sizes(7) - - !Simplistic way - isL=G%isc-G%isd+1 - ieL=G%iec-G%isd+1 - jsL=G%jsc-G%jsd+1 - jeL=G%jec-G%jsd+1 - !Zhi's way -! call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, caller="save_restart") -! select case (hor_grid) -! case ('q') ; pos = CORNER -! case ('h') ; pos = CENTER -! case ('u') ; pos = EAST_FACE -! case ('v') ; pos = NORTH_FACE -! case ('Bu') ; pos = CORNER -! case ('T') ; pos = CENTER -! case ('Cu') ; pos = EAST_FACE -! case ('Cv') ; pos = NORTH_FACE -! case ('1') ; pos = 0 -! case default ; pos = 0 -! end select -! call mpp_get_domain_shift(G%Domain%mpp_domain, ishift, jshift, pos) -! iadd = G%iec-G%isc ! Size of the i-dimension on this processor (-1 as it is an increment) -! jadd = G%jec-G%jsc ! Size of the j-dimension on this processor -! if(G%iec == G%ieg) iadd = iadd + ishift -! if(G%jec == G%jeg) jadd = jadd + jshift - !Bob's way - ! NOTE: The index ranges f var_ptrs always start with 1, so with - ! symmetric memory the staggering is swapped from NE to SW! -! is0 = 1-G%isd -! if ((pos == EAST_FACE) .or. (pos == CORNER)) is0 = 1-G%IsdB -! if (sizes(1) == G%iec-G%isc+1) then -! isL = G%isc+is0 ; ieL = G%iec+is0 -! elseif (sizes(1) == G%IecB-G%IscB+1) then -! isL = G%IscB+is0 ; ieL = G%IecB+is0 -! elseif (((pos == EAST_FACE) .or. (pos == CORNER)) .and. & -! (G%IscB == G%isc) .and. (sizes(1) == G%iec-G%isc+2)) then -! ! This is reading a symmetric file in a non-symmetric model. -! isL = G%isc-1+is0 ; ieL = G%iec+is0 -! else -! call MOM_error(WARNING, "MOM_restart restore_state, i-size ") -! endif -! -! js0 = 1-G%jsd -! if ((pos == NORTH_FACE) .or. (pos == CORNER)) js0 = 1-G%JsdB -! if (sizes(2) == G%jec-G%jsc+1) then -! jsL = G%jsc+js0 ; jeL = G%jec+js0 -! elseif (sizes(2) == G%jecB-G%jscB+1) then -! jsL = G%jscB+js0 ; jeL = G%jecB+js0 -! elseif (((pos == NORTH_FACE) .or. (pos == CORNER)) .and. & -! (G%JscB == G%jsc) .and. (sizes(2) == G%jec-G%jsc+2)) then -! ! This is reading a symmetric file in a non-symmetric model. -! jsL = G%jsc-1+js0 ; jeL = G%jec+js0 -! else -! call MOM_error(WARNING, "MOM_restart restore_state, wrong j-size ") -! endif - -end subroutine get_MOM_compute_domain +!> Return bounds for computing checksums to store in restart files +subroutine get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: pos !< An integer indicating staggering of variable + integer, intent(out) :: isL !< i-start for checksum + integer, intent(out) :: ieL !< i-end for checksum + integer, intent(out) :: jsL !< j-start for checksum + integer, intent(out) :: jeL !< j-end for checksum + + ! Regular non-symmetric compute domain + isL = G%isc-G%isd+1 + ieL = G%iec-G%isd+1 + jsL = G%jsc-G%jsd+1 + jeL = G%jec-G%jsd+1 + + ! Expand range east or south for symmetric arrays + if (G%symmetric) then + if ((pos == EAST_FACE) .or. (pos == CORNER)) then ! For u-, q-points only + if (G%idg_offset == 0) isL = isL - 1 ! include western edge in checksums only for western PEs + endif + if ((pos == NORTH_FACE) .or. (pos == CORNER)) then ! For v-, q-points only + if (G%jdg_offset == 0) jsL = jsL - 1 ! include western edge in checksums only for southern PEs + endif + endif + +end subroutine get_checksum_loop_ranges end module MOM_restart From 444b7cf73a68e290adb2ebb9cc055342bfde7d92 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 25 Jan 2018 16:08:43 -0800 Subject: [PATCH 153/170] Remove add_tracer_diagnostics With the reorganization of the tracer registry, add_tracer_diagnostics has been deprecated. register_tracer_diagnostics handles the functionality now. --- src/core/MOM.F90 | 2 +- src/tracer/DOME_tracer.F90 | 2 +- src/tracer/ISOMIP_tracer.F90 | 2 +- src/tracer/MOM_generic_tracer.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 53 ++------------------------ src/tracer/advection_test_tracer.F90 | 2 +- src/tracer/boundary_impulse_tracer.F90 | 2 +- src/tracer/dye_example.F90 | 2 +- src/tracer/dyed_obc_tracer.F90 | 2 +- src/tracer/ideal_age_example.F90 | 2 +- src/tracer/oil_tracer.F90 | 2 +- src/tracer/pseudo_salt_tracer.F90 | 2 +- src/tracer/tracer_example.F90 | 2 +- 13 files changed, 15 insertions(+), 62 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8329a7123f..5b93f1a443 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -123,7 +123,7 @@ module MOM use MOM_tracer_registry, only : register_tracer, tracer_registry_init use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics -use MOM_tracer_registry, only : add_tracer_diagnostics, tracer_registry_type +use MOM_tracer_registry, only : tracer_registry_type use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_CS use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index b4f19060a1..b65b6caefd 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -15,7 +15,7 @@ module DOME_tracer use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 599574d4d1..2cfb793802 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -28,7 +28,7 @@ module ISOMIP_tracer use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface use MOM_open_boundary, only : ocean_OBC_type diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 7bf85e5ecb..4a7526aedc 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -38,7 +38,7 @@ module MOM_generic_tracer use MOM_time_manager, only : time_type, get_time, set_time use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_registry, only : register_tracer, tracer_registry_type - use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values + use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_Z_init, only : tracer_Z_init use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z use MOM_variables, only : surface, thermo_var_ptrs diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 5def083740..44ffb1840c 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -29,7 +29,7 @@ module MOM_tracer_registry public MOM_tracer_chksum, MOM_tracer_chkinv public register_tracer_diagnostics, post_tracer_diagnostics public preALE_tracer_diagnostics, postALE_tracer_diagnostics -public add_tracer_diagnostics, add_tracer_OBC_values +public add_tracer_OBC_values public tracer_registry_init, lock_tracer_registry, tracer_registry_end !> The tracer type @@ -327,53 +327,6 @@ subroutine add_tracer_OBC_values(name, Reg, OBC_inflow, OBC_in_u, OBC_in_v) end subroutine add_tracer_OBC_values - -!> This subroutine adds diagnostic arrays for a tracer that has -!! previously been registered by a call to register_tracer. -subroutine add_tracer_diagnostics(name, Reg, ad_x, ad_y, df_x, df_y, & - ad_2d_x, ad_2d_y, df_2d_x, df_2d_y,& - advection_xy) - character(len=*), intent(in) :: name !< name of the tracer for which the diagnostic points - type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry - real, dimension(:,:,:), pointer, optional :: ad_x !< diagnostic x-advective flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:,:), pointer, optional :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:,:), pointer, optional :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:,:), pointer, optional :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: ad_2d_x !< vert sum of diagnostic x-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: ad_2d_y !< vert sum of diagnostic y-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: df_2d_x !< vert sum of diagnostic x-diffuse flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), pointer, optional :: df_2d_y !< vert sum of diagnostic y-diffuse flux (CONC m3/s or CONC*kg/s) - - real, dimension(:,:,:), pointer, optional :: advection_xy !< convergence of lateral advective tracer fluxes - - integer :: m - - if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_diagnostics: "// & - "register_tracer must be called before add_tracer_diagnostics") - - do m=1,Reg%ntr ; if (Reg%Tr(m)%name == trim(name)) exit ; enddo - - if (m <= Reg%ntr) then - if (present(ad_x)) then ; if (associated(ad_x)) Reg%Tr(m)%ad_x => ad_x ; endif - if (present(ad_y)) then ; if (associated(ad_y)) Reg%Tr(m)%ad_y => ad_y ; endif - if (present(df_x)) then ; if (associated(df_x)) Reg%Tr(m)%df_x => df_x ; endif - if (present(df_y)) then ; if (associated(df_y)) Reg%Tr(m)%df_y => df_y ; endif - - if (present(ad_2d_x)) then ; if (associated(ad_2d_x)) Reg%Tr(m)%ad2d_x => ad_2d_x ; endif - if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Reg%Tr(m)%ad2d_y => ad_2d_y ; endif - if (present(df_2d_x)) then ; if (associated(df_2d_x)) Reg%Tr(m)%df2d_x => df_2d_x ; endif - if (present(df_2d_y)) then ; if (associated(df_2d_y)) Reg%Tr(m)%df2d_y => df_2d_y ; endif - - if (present(advection_xy)) then ; if (associated(advection_xy)) Reg%Tr(m)%advection_xy => advection_xy ; endif - - else - - call MOM_error(FATAL, "MOM_tracer: register_tracer must be called for "//& - trim(name)//" before add_tracer_diagnostics is called for it.") - endif - -end subroutine add_tracer_diagnostics - !> register_tracer_diagnostics does a set of register_diag_field calls for any previously !! registered in a tracer registry with a value of registry_diags set to .true. subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_to_Z_CSp) @@ -412,8 +365,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_diagnostics: "// & - "register_tracer must be called before add_tracer_diagnostics") + if (.not. associated(Reg)) call MOM_error(FATAL, "register_tracer_diagnostics: "// & + "register_tracer must be called before register_tracer_diagnostics") nTr_in = Reg%ntr diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index d193476af7..6a1cb576b3 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -49,7 +49,7 @@ module advection_test_tracer use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 7dda599a52..00f3d90d90 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -16,7 +16,7 @@ module boundary_impulse_tracer use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_variables, only : surface diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 52a578c96a..a8ca61c762 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -15,7 +15,7 @@ module regional_dyes use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_variables, only : surface diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index f3e7563440..f299ba95cb 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -14,7 +14,7 @@ module dyed_obc_tracer use MOM_restart, only : MOM_restart_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 91f410396d..51cc79f0a7 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -50,7 +50,7 @@ module ideal_age_example use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_variables, only : surface diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 7f97cfbedc..9240db9524 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -50,7 +50,7 @@ module oil_tracer use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_variables, only : surface diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index fde068aa52..ee57789297 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -50,7 +50,7 @@ module pseudo_salt_tracer use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_variables, only : surface diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 3166667849..7c5e8e26b4 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -46,7 +46,7 @@ module USER_tracer_example use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, get_time use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_registry, only : add_tracer_OBC_values use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type From badd7dbb846652c0922019165bea2f0e90bc13cf Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 25 Jan 2018 22:50:24 -0500 Subject: [PATCH 154/170] Implements a flag to recover wrong sign for net FW adjustment - The sign fix for the net fresh water adjustment is correct but we need to document the change to solutions so need a run-time flag to recover the old/wrong answers. - Initially setting the default to recover old answers. - Thanks to @travissluka for chasing this one down. --- config_src/coupled_driver/MOM_surface_forcing.F90 | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 693533be80..6b0fedc336 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -112,6 +112,7 @@ module MOM_surface_forcing logical :: adjust_net_srestore_to_zero ! adjust srestore to zero (for both salt_flux or vprec) logical :: adjust_net_srestore_by_scaling ! adjust srestore w/o moving zero contour logical :: adjust_net_fresh_water_to_zero ! adjust net surface fresh-water (w/ restoring) to zero + logical :: use_net_FW_adjustment_sign_bug ! use the wrong sign when adjusting net FW logical :: adjust_net_fresh_water_by_scaling ! adjust net surface fresh-water w/o moving zero contour logical :: mask_srestore_under_ice ! If true, use an ice mask defined by frazil ! criteria for salinity restoring. @@ -268,6 +269,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, real :: delta_sst ! temporary storage for sst diff from restoring value real :: C_p ! heat capacity of seawater ( J/(K kg) ) + real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. call cpu_clock_begin(id_clock_forcing) @@ -549,6 +551,8 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, ! adjust the NET fresh-water flux to zero, if flagged if (CS%adjust_net_fresh_water_to_zero) then + sign_for_net_FW_bug = 1. + if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & @@ -560,7 +564,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, ! is constant. ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA if (ASSOCIATED(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) + G%areaT(i,j) * & + net_FW(i,j) = net_FW(i,j) + sign_for_net_FW_bug * G%areaT(i,j) * & (IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) enddo ; enddo @@ -930,6 +934,11 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res CS%adjust_net_fresh_water_to_zero, & "If true, adjusts the net fresh-water forcing seen \n"//& "by the ocean (including restoring) to zero.", default=.false.) + if (CS%adjust_net_fresh_water_to_zero) & + call get_param(param_file, mdl, "USE_NET_FW_ADJUSTMENT_SIGN_BUG", & + CS%use_net_FW_adjustment_sign_bug, & + "If true, use the wrong sign for the adjustment to\n"//& + "the net fresh-water.", default=.true.) call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & CS%adjust_net_fresh_water_by_scaling, & "If true, adjustments to net fresh water to achieve zero net are\n"//& From 78031f92a9e783af158ba660af0979cae6e2cbba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 26 Jan 2018 09:32:16 -0500 Subject: [PATCH 155/170] +Moved ENERGYSAVEDAYS into MOM_sum_output.F90 Moved the code that determines the ocean.stats output frequency into MOM_sum_output, which allows the code that is duplicated between the various drivers to be eliminated. Also added the runtime parameter WRITE_CPU_STEPS, which determines how often MOM checks CPU time in ocean-only runs. All answers are bitwise identical, but the entries and order of entries in the MOM_parameter_doc files change. --- config_src/coupled_driver/ocean_model_MOM.F90 | 82 ++----------------- config_src/solo_driver/MOM_driver.F90 | 60 +++++++------- src/diagnostics/MOM_sum_output.F90 | 82 ++++++++++++++++++- 3 files changed, 114 insertions(+), 110 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index d6fb9b7f57..c702dffcc9 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -148,19 +148,6 @@ module ocean_model_mod !! restart file is saved at the end of a run segment !! unless Restart_control is negative. - type(time_type) :: energysavedays !< The interval between writing the energies - !! and other integral quantities of the run. - type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric - !! progression of time deltas between calls to - !! write_energy. This interval will increase by a factor of 2. - !! after each call to write_energy. - logical :: energysave_geometric !< Logical to control whether calls to write_energy should - !! follow a geometric progression - type(time_type) :: write_energy_time !< The next time to write to the energy file. - type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression - !! of calls to write_energy and revert to the standard - !! energysavedays interval - integer :: nstep = 0 !< The number of calls to update_ocean. logical :: use_ice_shelf !< If true, the ice shelf model is enabled. @@ -254,7 +241,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) ! information about the ocean's interior state. ! (in) Time_init - The start time for the coupled model's calendar. ! (in) Time_in - The time at which to initialize the ocean model. - real :: Time_unit ! The time unit in seconds for ENERGYSAVEDAYS. real :: Rho0 ! The Boussinesq ocean density, in kg m-3. real :: G_Earth ! The gravitational acceleration in m s-2. ! This include declares and sets the variable "version". @@ -286,6 +272,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%fluxes%C_p = OS%MSp%tv%C_p use_temperature = ASSOCIATED(OS%MSp%tv%T) + call MOM_sum_output_init(OS%grid, param_file, OS%dirs%output_directory, & + OS%MOM_CSp%ntrunc, Time_init, OS%sum_output_CSp) + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RESTART_CONTROL", OS%Restart_control, & @@ -295,26 +284,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) "will be saved at the end of the run segment for any \n"//& "non-negative value.", default=1) - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & - "The time unit for ENERGYSAVEDAYS.", & - units="s", default=86400.0) - call get_param(param_file, mdl, "ENERGYSAVEDAYS",OS%energysavedays, & - "The interval in units of TIMEUNIT between saves of the \n"//& - "energies of the run and other globally summed diagnostics.",& - default=set_time(0,days=1), timeunit=Time_unit) - call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",OS%energysavedays_geometric, & - "The starting interval in units of TIMEUNIT for the first call \n"//& - "to save the energies of the run and other globally summed diagnostics. \n"//& - "The interval increases by a factor of 2. after each call to write_energy.",& - default=set_time(seconds=0), timeunit=Time_unit) - - if ((time_type_to_real(OS%energysavedays_geometric) > 0.) .and. & - (OS%energysavedays_geometric < OS%energysavedays)) then - OS%energysave_geometric = .true. - else - OS%energysave_geometric = .false. - endif - call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & "A case-insensitive character string to indicate the \n"//& "staggering of the surface velocity field that is \n"//& @@ -384,28 +353,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call allocate_forcing_type(OS%grid, OS%fluxes, shelf=.true.) endif - call MOM_sum_output_init(OS%grid, param_file, OS%dirs%output_directory, & - OS%MOM_CSp%ntrunc, Time_init, OS%sum_output_CSp) - ! This call has been moved into the first call to update_ocean_model. ! call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & ! OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, OS%MOM_CSp%tracer_flow_CSp) - ! write_energy_time is the next integral multiple of energysavedays. - if (OS%energysave_geometric) then - if (OS%energysavedays_geometric < OS%energysavedays) then - OS%write_energy_time = OS%Time + OS%energysavedays_geometric - OS%geometric_end_time = Time_init + OS%energysavedays * & - (1 + (OS%Time - Time_init) / OS%energysavedays) - else - OS%write_energy_time = Time_init + OS%energysavedays * & - (1 + (OS%Time - Time_init) / OS%energysavedays) - endif - else - OS%write_energy_time = Time_init + OS%energysavedays * & - (1 + (OS%Time - Time_init) / OS%energysavedays) - endif - if (ASSOCIATED(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & OS%diag, maskmap=OS%grid%Domain%maskmap, & @@ -497,7 +448,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & real :: time_step ! The time step of a call to step_MOM in seconds. integer :: secs, days integer :: is, ie, js, je - type(time_type) :: write_energy_time_geometric call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") call get_time(Ocean_coupling_time_step, secs, days) @@ -611,32 +561,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call disable_averaging(OS%diag) endif -! See if it is time to write out the energy. - - if (OS%energysave_geometric) then - if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%geometric_end_time) .and. & - (OS%MSp%t_dyn_rel_adv==0.0)) then - call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & - OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & - OS%MOM_CSp%tracer_flow_CSp) - OS%write_energy_time = OS%geometric_end_time + OS%energysavedays - OS%energysave_geometric = .false. ! stop geometric progression - endif - endif - - if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%write_energy_time) .and. & - (OS%MSp%t_dyn_rel_adv==0.0)) then + if (OS%MSp%t_dyn_rel_adv==0.0) & call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & - OS%MOM_CSp%tracer_flow_CSp) - if (OS%energysave_geometric) then - OS%energysavedays_geometric = OS%energysavedays_geometric*2 - OS%write_energy_time = OS%write_energy_time + OS%energysavedays_geometric - else - OS%write_energy_time = OS%write_energy_time + OS%energysavedays - endif - endif - + OS%MOM_CSp%tracer_flow_CSp, dt_forcing=Ocean_coupling_time_step) ! Translate state into Ocean. diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 1975d8ec8d..d5bc2da6ba 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -113,7 +113,6 @@ program MOM_main type(time_type) :: Start_time ! The start time of the simulation. type(time_type) :: segment_start_time ! The start time of this run segment. type(time_type) :: Time_end ! End time for the segment or experiment. - type(time_type) :: write_energy_time ! The next time to write to the energy file. type(time_type) :: restart_time ! The next time to write restart files. type(time_type) :: Time_step_ocean ! A time_type version of time_step. @@ -138,9 +137,8 @@ program MOM_main real :: Time_unit ! The time unit in seconds for the following input fields. type(time_type) :: restint ! The time between saves of the restart file. type(time_type) :: daymax ! The final day of the simulation. - type(time_type) :: energysavedays ! The interval between writing the energies - ! and other integral quantities of the run. + integer :: CPU_steps ! The number of steps between writing CPU time. integer :: date_init(6)=0 ! The start date of the whole simulation. integer :: date(6)=-1 ! Possibly the start date of this run segment. integer :: years=0, months=0, days=0 ! These may determine the segment run @@ -301,6 +299,11 @@ program MOM_main Master_Time = Time grid => MSp%G GV => MSp%GV + + call MOM_sum_output_init(grid, param_file, dirs%output_directory, & + MOM_CSp%ntrunc, Start_time, sum_output_CSp) + call callTree_waypoint("done MOM_sum_output_init") + call calculate_surface_state(sfc_state, MSp%u, MSp%v, MSp%h, & MSp%ave_ssh, grid, GV, MSp, MOM_CSp) @@ -318,12 +321,6 @@ program MOM_main diag, forces, fluxes) endif - call MOM_sum_output_init(grid, param_file, dirs%output_directory, & - MOM_CSp%ntrunc, Start_time, sum_output_CSp) - call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & - write_CPU_CSp) - call callTree_waypoint("done MOM_sum_output_init") - segment_start_time = Time elapsed_time = 0.0 @@ -385,15 +382,20 @@ program MOM_main "of TIMEUNIT. Use 0 (the default) to not save \n"//& "incremental restart files at all.", default=set_time(0), & timeunit=Time_unit) - call get_param(param_file, mod_name, "ENERGYSAVEDAYS", energysavedays, & - "The interval in units of TIMEUNIT between saves of the \n"//& - "energies of the run and other globally summed diagnostics.", & - default=set_time(int(time_step+0.5)), timeunit=Time_unit) + call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & + "The number of coupled timesteps between writing the cpu \n"//& + "time. If this is not positive, do not check cpu time, and \n"//& + "the segment run-length can not be set via an elapsed CPU time.", & + default=1000) call get_param(param_file, "MOM", "DEBUG", debug, & "If true, write out verbose debugging data.", default=.false.) call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) + if (cpu_steps > 0) & + call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & + write_CPU_CSp) + ! Close the param_file. No further parsing of input is possible after this. call close_param_file(param_file) call diag_mediator_close_registration(diag) @@ -414,10 +416,7 @@ program MOM_main ! This has been moved inside the loop to be applied when n=1. ! call write_energy(MSp%u, MSp%v, MSp%h, & ! MSp%tv, Time, 0, grid, GV, sum_output_CSp, MOM_CSp%tracer_flow_CSp) - call write_cputime(Time, 0, nmax, write_CPU_CSp) - - write_energy_time = Start_time + energysavedays * & - (1 + (Time - Start_time) / energysavedays) + if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. @@ -481,7 +480,7 @@ program MOM_main if (elapsed_time > 2e9) then ! This is here to ensure that the conversion from a real to an integer ! can be accurately represented in long runs (longer than ~63 years). - ! It will also ensure that elapsed time does not loose resolution of order + ! It will also ensure that elapsed time does not lose resolution of order ! the timetype's resolution, provided that the timestep and tick are ! larger than 10-5 seconds. If a clock with a finer resolution is used, ! a smaller value would be required. @@ -495,6 +494,19 @@ program MOM_main endif Time = Master_Time + if (fluxes%fluxes_used .and. (.not.offline_tracer_mode)) & + call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, sum_output_CSp) + +! See if it is time to write out the energy. + if (MSp%t_dyn_rel_adv == 0.0) & + call write_energy(MSp%u, MSp%v, MSp%h, & + MSp%tv, Time, n+ntstep-1, grid, GV, sum_output_CSp, & + MOM_CSp%tracer_flow_CSp, dt_forcing=Time_step_ocean) + + if (cpu_steps > 0) then ; if (MOD(n, cpu_steps) == 0) then + call write_cputime(Time, n+ntstep-1, nmax, write_CPU_CSp) + endif ; endif + call enable_averaging(time_step, Time, diag) call mech_forcing_diags(forces, fluxes, time_step, grid, diag, & surface_forcing_CSp%handles) @@ -505,7 +517,7 @@ program MOM_main call enable_averaging(fluxes%dt_buoy_accum, Time, diag) call forcing_diagnostics(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, & diag, surface_forcing_CSp%handles) - call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, sum_output_CSp) +! call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, sum_output_CSp) call disable_averaging(diag) else call MOM_error(FATAL, "The solo MOM_driver is not yet set up to handle "//& @@ -513,16 +525,6 @@ program MOM_main endif endif -! See if it is time to write out the energy. - if ((Time + (Time_step_ocean/2) > write_energy_time) .and. & - (MSp%t_dyn_rel_adv == 0.0)) then - call write_energy(MSp%u, MSp%v, MSp%h, & - MSp%tv, Time, n+ntstep-1, grid, GV, sum_output_CSp, & - MOM_CSp%tracer_flow_CSp) - call write_cputime(Time, n+ntstep-1, nmax, write_CPU_CSp) - write_energy_time = write_energy_time + energysavedays - endif - ! See if it is time to write out a restart file - timestamped or not. if ((permit_incr_restart) .and. (fluxes%fluxes_used) .and. & (Time + (Time_step_ocean/2) > restart_time)) then diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 2440724331..930f02fcd2 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -51,8 +51,10 @@ module MOM_sum_output use MOM_io, only : APPEND_FILE, ASCII_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S -use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>), operator(-) -use MOM_time_manager, only : get_calendar_type, NO_CALENDAR +use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_stocks use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -114,6 +116,20 @@ module MOM_sum_output net_salt_in_EFP, & ! correspondingly named variables above. net_heat_in_EFP, heat_prev_EFP, salt_prev_EFP, mass_prev_EFP real :: dt ! The baroclinic dynamics time step, in s. + + type(time_type) :: energysavedays !< The interval between writing the energies + !! and other integral quantities of the run. + type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric + !! progression of time deltas between calls to + !! write_energy. This interval will increase by a factor of 2. + !! after each call to write_energy. + logical :: energysave_geometric !< Logical to control whether calls to write_energy should + !! follow a geometric progression + type(time_type) :: write_energy_time !< The next time to write to the energy file. + type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression + !! of calls to write_energy and revert to the standard + !! energysavedays interval + real :: timeunit ! The length of the units for the time ! axis, in s. logical :: date_stamped_output ! If true, use dates (not times) in messages to stdout. @@ -145,7 +161,7 @@ module MOM_sum_output !> MOM_sum_output_init initializes the parameters and settings for the MOM_sum_output module. subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & - Input_start_time, CS) + Input_start_time, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. @@ -165,6 +181,7 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & ! (in) Input_start_time - The start time of the simulation. ! (in/out) CS - A pointer that is set to point to the control structure ! for this module + real :: Time_unit ! The time unit in seconds for ENERGYSAVEDAYS. real :: Rho_0, maxvel ! This include declares and sets the variable "version". #include "version_variable.h" @@ -261,6 +278,28 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & CS%list_size = 0 endif + call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & + "The time unit for ENERGYSAVEDAYS.", & + units="s", default=86400.0) + call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & + "The interval in units of TIMEUNIT between saves of the \n"//& + "energies of the run and other globally summed diagnostics.",& + default=set_time(0,days=1), timeunit=Time_unit) + call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & + "The starting interval in units of TIMEUNIT for the first call \n"//& + "to save the energies of the run and other globally summed diagnostics. \n"//& + "The interval increases by a factor of 2. after each call to write_energy.",& + default=set_time(seconds=0), timeunit=Time_unit) + + if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & + (CS%energysavedays_geometric < CS%energysavedays)) then + CS%energysave_geometric = .true. + else + CS%energysave_geometric = .false. + endif + + + CS%Huge_time = set_time(INT(1e9),0) CS%Start_time = Input_start_time CS%ntrunc => ntrnc @@ -284,7 +323,7 @@ end subroutine MOM_sum_output_end !> This subroutine calculates and writes the total model energy, the !! energy and mass of each layer, and other globally integrated !! physical quantities. -subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC) +subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forcing) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. @@ -303,6 +342,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC) !! MOM_sum_output_init. type(tracer_flow_control_CS), optional, pointer :: tracer_CSp !< tracer constrol structure. type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + type(time_type), optional, intent(in) :: dt_forcing !< The forcing time step real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! The height of interfaces, in m. real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT, in m2. @@ -381,6 +421,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC) character(len=200) :: mesg character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str logical :: date_stamped + type(time_type) :: dt_force real :: Tr_stocks(MAX_FIELDS_) real :: Tr_min(MAX_FIELDS_),Tr_max(MAX_FIELDS_) real :: Tr_min_x(MAX_FIELDS_), Tr_min_y(MAX_FIELDS_), Tr_min_z(MAX_FIELDS_) @@ -398,6 +439,39 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC) ! A description for output of each of the fields. type(vardesc) :: vars(NUM_FIELDS+MAX_FIELDS_) + ! write_energy_time is the next integral multiple of energysavedays. + dt_force = set_time(seconds=2) ; if (present(dt_forcing)) dt_force = dt_forcing + if (CS%previous_calls == 0) then + if (CS%energysave_geometric) then + if (CS%energysavedays_geometric < CS%energysavedays) then + CS%write_energy_time = day + CS%energysavedays_geometric + CS%geometric_end_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + elseif (day + (dt_force/2) <= CS%write_energy_time) then + return ! Do not write this step + else ! Determine the next write time before proceeding + if (CS%energysave_geometric) then + CS%energysavedays_geometric = CS%energysavedays_geometric*2 + if (CS%write_energy_time + CS%energysavedays_geometric >= & + CS%geometric_end_time) then + CS%write_energy_time = CS%geometric_end_time + CS%energysave_geometric = .false. ! stop geometric progression + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays_geometric + endif + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays + endif + endif + num_nc_fields = 17 if (.not.CS%use_temperature) num_nc_fields = 11 vars(1) = var_desc("Ntrunc","Nondim","Number of Velocity Truncations",'1','1') From dd8fdd60581f19081625add01ed1d357b189e37e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 26 Jan 2018 17:42:02 -0500 Subject: [PATCH 156/170] Generate fatal error with excessive energy or NaNs Changed the behavior of MOM_sum_output when NaNs or excessive energy per unit mass are detected to give a fatal error, rather than resetting the time to a huge value as before. This now replicates the error handling with an excessive number of velocity truncations. All answers are bitwise identical, although the ocean-only model behavior changes during model failures. --- src/diagnostics/MOM_sum_output.F90 | 61 ++++++++++++------------------ 1 file changed, 25 insertions(+), 36 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 930f02fcd2..9ff9410f49 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -16,8 +16,7 @@ module MOM_sum_output !* * !* In addition, if the number of velocity truncations since the * !* previous call to write_energy exceeds maxtrunc or the total energy * -!* exceeds a very large threshold, the day is increased to Huge_time * -!* so that the model will gracefully halt itself. * +!* exceeds a very large threshold, a fatal termination is triggered. * !* * !* This file also contains a few miscelaneous initialization * !* calls to FMS-related modules. * @@ -135,10 +134,6 @@ module MOM_sum_output logical :: date_stamped_output ! If true, use dates (not times) in messages to stdout. type(time_type) :: Start_time ! The start time of the simulation. ! Start_time is set in MOM_initialization.F90 - type(time_type) :: Huge_time ! A large time, which is used to indicate - ! that an error has been encountered - ! and the run should be terminated with - ! an error code. integer, pointer :: ntrunc ! The number of times the velocity has been ! truncated since the last call to write_energy. real :: max_Energy ! The maximum permitted energy per unit mass; @@ -298,9 +293,6 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & CS%energysave_geometric = .false. endif - - - CS%Huge_time = set_time(INT(1e9),0) CS%Start_time = Input_start_time CS%ntrunc => ntrnc @@ -320,29 +312,29 @@ subroutine MOM_sum_output_end(CS) endif end subroutine MOM_sum_output_end -!> This subroutine calculates and writes the total model energy, the -!! energy and mass of each layer, and other globally integrated -!! physical quantities. +!> This subroutine calculates and writes the total model energy, the energy and +!! mass of each layer, and other globally integrated physical quantities. subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forcing) - 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)), intent(in) :: u !< The zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, - !! in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - type(time_type), intent(inout) :: day !< The current model time. - integer, intent(in) :: n !< The time step number of the - !! current execution. - type(Sum_output_CS), pointer :: CS !< The control structure returned - !! by a previous call to - !! MOM_sum_output_init. - type(tracer_flow_control_CS), optional, pointer :: tracer_CSp !< tracer constrol structure. - type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. - type(time_type), optional, intent(in) :: dt_forcing !< The forcing time step + 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)), & + intent(in) :: u !< The zonal velocity, in m s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< The meridional velocity, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(time_type), intent(in) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the + !! current execution. + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + type(tracer_flow_control_CS), & + optional, pointer :: tracer_CSp !< tracer control structure. + type(ocean_OBC_type), & + optional, pointer :: OBC !< Open boundaries control structure. + type(time_type), optional, intent(in) :: dt_forcing !< The forcing time step real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! The height of interfaces, in m. real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT, in m2. @@ -934,15 +926,12 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc ! The second (impossible-looking) test looks for a NaN in En_mass. if ((En_mass>CS%max_Energy) .or. & ((En_mass>CS%max_Energy) .and. (En_massCS%maxtrunc) then - day = CS%Huge_time call MOM_error(FATAL, "write_energy : Ocean velocity has been truncated too many times.") endif CS%ntrunc = 0 From 93656d4335e89dbf27b7e37827e2a5addb0ed2df Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 26 Jan 2018 17:44:44 -0500 Subject: [PATCH 157/170] +Moved write_energy into step_MOM Moved all calls to write_energy, MOM_sum_output_init, and accumulate_net_input into MOM.F90 and out of the various MOM drivers. All answers are bitwise identical, but there are changes to public types and a new optional argument (count_calls) has been added to initialize_MOM. --- config_src/coupled_driver/ocean_model_MOM.F90 | 30 ++---------- config_src/mct_driver/ocn_comp_mct.F90 | 46 ++----------------- config_src/solo_driver/MOM_driver.F90 | 35 ++------------ src/core/MOM.F90 | 39 +++++++++++++++- 4 files changed, 48 insertions(+), 102 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index c702dffcc9..110ccd8769 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -36,8 +36,6 @@ module ocean_model_mod use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number use MOM_restart, only : MOM_restart_CS, save_restart -use MOM_sum_output, only : write_energy, accumulate_net_input -use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS use MOM_string_functions, only : uppercase use MOM_surface_forcing, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing, only : ice_ocn_bnd_type_chksum @@ -193,8 +191,6 @@ module ocean_model_mod !! is null if there is no ice shelf. type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(sum_output_CS), pointer :: & - sum_output_CSp => NULL() !< A pointer to the MOM sum output control structure type(MOM_restart_CS), pointer :: & restart_CSp => NULL() !< A pointer set to the restart control structure !! that will be used for MOM restart files. @@ -264,17 +260,14 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) if (.not.OS%is_ocean_pe) return OS%Time = Time_in - call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, OS%restart_CSp, & - Time_in, offline_tracer_mode=offline_tracer_mode, & - diag_ptr=OS%diag) + call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, & + OS%restart_CSp, Time_in, offline_tracer_mode=offline_tracer_mode, & + diag_ptr=OS%diag, count_calls=.true.) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV OS%C_p = OS%MSp%tv%C_p OS%fluxes%C_p = OS%MSp%tv%C_p use_temperature = ASSOCIATED(OS%MSp%tv%T) - call MOM_sum_output_init(OS%grid, param_file, OS%dirs%output_directory, & - OS%MOM_CSp%ntrunc, Time_init, OS%sum_output_CSp) - ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RESTART_CONTROL", OS%Restart_control, & @@ -283,7 +276,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) "(bit 0) for a non-time-stamped file. A restart file \n"//& "will be saved at the end of the run segment for any \n"//& "non-negative value.", default=1) - call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & "A case-insensitive character string to indicate the \n"//& "staggering of the surface velocity field that is \n"//& @@ -353,10 +345,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call allocate_forcing_type(OS%grid, OS%fluxes, shelf=.true.) endif - ! This call has been moved into the first call to update_ocean_model. - ! call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & - ! OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, OS%MOM_CSp%tracer_flow_CSp) - if (ASSOCIATED(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & OS%diag, maskmap=OS%grid%Domain%maskmap, & @@ -529,10 +517,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%nstep==0) then call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes, & OS%restart_CSp) - - call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & - OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, & - OS%MOM_CSp%tracer_flow_CSp) endif call disable_averaging(OS%diag) @@ -556,17 +540,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & OS%grid, OS%diag, OS%forcing_CSp%handles) - call accumulate_net_input(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%sum_output_CSp) call disable_averaging(OS%diag) endif - if (OS%MSp%t_dyn_rel_adv==0.0) & - call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & - OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & - OS%MOM_CSp%tracer_flow_CSp, dt_forcing=Ocean_coupling_time_step) - - ! Translate state into Ocean. ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 4638593593..e4772af614 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -57,8 +57,6 @@ module ocn_comp_mct use MOM_diag_mediator, only: safe_alloc_ptr use MOM_ice_shelf, only: initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS use MOM_ice_shelf, only: ice_shelf_end, ice_shelf_save_restart -use MOM_sum_output, only: MOM_sum_output_init, sum_output_CS -use MOM_sum_output, only: write_energy, accumulate_net_input use MOM_string_functions, only: uppercase use MOM_constants, only: CELSIUS_KELVIN_OFFSET, hlf, hlv use MOM_EOS, only: gsw_sp_from_sr, gsw_pt_from_ct @@ -297,9 +295,6 @@ module ocn_comp_mct !! files and +2 (bit 1) for time-stamped files. A !! restart file is saved at the end of a run segment !! unless Restart_control is negative. - type(time_type) :: energysavedays !< The interval between writing the energies - !! and other integral quantities of the run. - type(time_type) :: write_energy_time !< The next time to write to the energy file. integer :: nstep = 0 !< The number of calls to update_ocean. logical :: use_ice_shelf !< If true, the ice shelf model is enabled. logical :: icebergs_apply_rigid_boundary !< If true, the icebergs can change ocean bd condition. @@ -332,7 +327,6 @@ module ocn_comp_mct type(MOM_control_struct), pointer :: MOM_CSp => NULL() type(MOM_state_type), pointer :: MSp => NULL() type(surface_forcing_CS), pointer :: forcing_CSp => NULL() - type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(MOM_restart_CS), pointer :: & restart_CSp => NULL() !< A pointer set to the restart control structure !! that will be used for MOM restart files. @@ -808,7 +802,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! Because of the way that indicies and domains are handled, Ocean_sfc must have ! been used in a previous call to initialize_ocean_type. - real :: Time_unit !< The time unit in seconds for ENERGYSAVEDAYS. real :: Rho0 !< The Boussinesq ocean density, in kg m-3. real :: G_Earth !< The gravitational acceleration in m s-2. !! This include declares and sets the variable "version". @@ -831,9 +824,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (.not.OS%is_ocean_pe) return OS%Time = Time_in - call initialize_MOM(OS%Time, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, & + call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=offline_tracer_mode, & - input_restart_file=input_restart_file, diag_ptr=OS%diag) + input_restart_file=input_restart_file, diag_ptr=OS%diag, & + count_calls=.true.) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV OS%C_p = OS%MSp%tv%C_p OS%fluxes%C_p = OS%MSp%tv%C_p @@ -847,14 +841,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "(bit 0) for a non-time-stamped file. A restart file \n"//& "will be saved at the end of the run segment for any \n"//& "non-negative value.", default=1) - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & - "The time unit for ENERGYSAVEDAYS.", & - units="s", default=86400.0) - call get_param(param_file, mdl, "ENERGYSAVEDAYS",OS%energysavedays, & - "The interval in units of TIMEUNIT between saves of the \n"//& - "energies of the run and other globally summed diagnostics.", & - default=set_time(0,days=1), timeunit=Time_unit) - call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & "A case-insensitive character string to indicate the \n"//& "staggering of the surface velocity field that is \n"//& @@ -923,17 +909,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (.not. OS%use_ice_shelf) call allocate_forcing_type(OS%grid, OS%fluxes, ustar=.true., shelf=.true.) endif - call MOM_sum_output_init(OS%grid, param_file, OS%dirs%output_directory, & - OS%MOM_CSp%ntrunc, Time_init, OS%sum_output_CSp) - - ! This call has been moved into the first call to update_ocean_model. -! call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & -! OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, OS%MOM_CSp%tracer_flow_CSp) - - ! write_energy_time is the next integral multiple of energysavedays. - OS%write_energy_time = Time_init + OS%energysavedays * & - (1 + (OS%Time - Time_init) / OS%energysavedays) - if (ASSOCIATED(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & OS%diag, maskmap=OS%grid%Domain%maskmap, & @@ -1786,10 +1761,6 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & if (OS%nstep==0) then call finish_MOM_initialization(OS%Time, OS%dirs, OS%MSp, OS%MOM_CSp, OS%fluxes, & OS%restart_CSp) - - call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & - OS%Time, 0, OS%grid, OS%GV, OS%sum_output_CSp, & - OS%MOM_CSp%tracer_flow_CSp) endif call disable_averaging(OS%diag) @@ -1813,20 +1784,9 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) call forcing_diagnostics(OS%fluxes, OS%state, OS%fluxes%dt_buoy_accum, & OS%grid, OS%diag, OS%forcing_CSp%handles) - call accumulate_net_input(OS%fluxes, OS%state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%sum_output_CSp) call disable_averaging(OS%diag) endif -! See if it is time to write out the energy. - if ((OS%Time + ((Ocean_coupling_time_step)/2) > OS%write_energy_time) .and. & - (OS%MSp%t_dyn_rel_adv==0.0)) then - call write_energy(OS%MSp%u, OS%MSp%v, OS%MSp%h, OS%MSp%tv, & - OS%Time, OS%nstep, OS%grid, OS%GV, OS%sum_output_CSp, & - OS%MOM_CSp%tracer_flow_CSp) - OS%write_energy_time = OS%write_energy_time + OS%energysavedays - endif - ! Translate state into Ocean. ! call convert_state_to_ocean_type(OS%state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index d5bc2da6ba..66e2f5d19b 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -45,8 +45,6 @@ program MOM_main use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions,only : uppercase - use MOM_sum_output, only : write_energy, accumulate_net_input - use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS use MOM_surface_forcing, only : set_forcing, forcing_save_restart use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS use MOM_time_manager, only : time_type, set_date, set_time, get_date, time_type_to_real @@ -95,7 +93,7 @@ program MOM_main ! nmax is the number of iterations after which to stop so that the ! simulation does not exceed its CPU time limit. nmax is determined by - ! evaluating the CPU time used between successive calls to write_energy. + ! evaluating the CPU time used between successive calls to write_cputime. ! Initially it is set to be very large. integer :: nmax=2000000000; @@ -170,7 +168,6 @@ program MOM_main type(MOM_control_struct), pointer :: MOM_CSp => NULL() type(MOM_state_type), pointer :: MSp => NULL() type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() - type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() type(MOM_restart_CS), pointer :: & @@ -283,31 +280,26 @@ program MOM_main ! In this case, the segment starts at a time fixed by ocean_solo.res segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time - ! Note the not before CS%d - call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & segment_start_time, offline_tracer_mode=offline_tracer_mode, & diag_ptr=diag) else ! In this case, the segment starts at a time read from the MOM restart file ! or left as Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & - offline_tracer_mode=offline_tracer_mode, diag_ptr=diag) + call initialize_MOM(Time, Start_time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & + offline_tracer_mode=offline_tracer_mode, diag_ptr=diag) endif fluxes%C_p = MSp%tv%C_p ! Copy the heat capacity for consistency. Master_Time = Time grid => MSp%G GV => MSp%GV - - call MOM_sum_output_init(grid, param_file, dirs%output_directory, & - MOM_CSp%ntrunc, Start_time, sum_output_CSp) - call callTree_waypoint("done MOM_sum_output_init") + call callTree_waypoint("done initialize_MOM") call calculate_surface_state(sfc_state, MSp%u, MSp%v, MSp%h, & MSp%ave_ssh, grid, GV, MSp, MOM_CSp) - call surface_forcing_init(Time, grid, param_file, diag, & surface_forcing_CSp, MOM_CSp%tracer_flow_CSp) call callTree_waypoint("done surface_forcing_init") @@ -413,9 +405,6 @@ program MOM_main call close_file(unit) endif -! This has been moved inside the loop to be applied when n=1. -! call write_energy(MSp%u, MSp%v, MSp%h, & -! MSp%tv, Time, 0, grid, GV, sum_output_CSp, MOM_CSp%tracer_flow_CSp) if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & @@ -460,10 +449,6 @@ program MOM_main if (n==1) then call finish_MOM_initialization(Time, dirs, MSp, MOM_CSp, fluxes, restart_CSp) - - call write_energy(MSp%u, MSp%v, MSp%h, MSp%tv, & - Time, 0, grid, GV, sum_output_CSp, MOM_CSp%tracer_flow_CSp, & - MOM_CSp%OBC) endif ! This call steps the model over a time time_step. @@ -494,15 +479,6 @@ program MOM_main endif Time = Master_Time - if (fluxes%fluxes_used .and. (.not.offline_tracer_mode)) & - call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, sum_output_CSp) - -! See if it is time to write out the energy. - if (MSp%t_dyn_rel_adv == 0.0) & - call write_energy(MSp%u, MSp%v, MSp%h, & - MSp%tv, Time, n+ntstep-1, grid, GV, sum_output_CSp, & - MOM_CSp%tracer_flow_CSp, dt_forcing=Time_step_ocean) - if (cpu_steps > 0) then ; if (MOD(n, cpu_steps) == 0) then call write_cputime(Time, n+ntstep-1, nmax, write_CPU_CSp) endif ; endif @@ -517,7 +493,6 @@ program MOM_main call enable_averaging(fluxes%dt_buoy_accum, Time, diag) call forcing_diagnostics(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, & diag, surface_forcing_CSp%handles) -! call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, sum_output_CSp) call disable_averaging(diag) else call MOM_error(FATAL, "The solo MOM_driver is not yet set up to handle "//& diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 1d3e6c0ef2..c460c6e7f4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -113,6 +113,8 @@ module MOM use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_init use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS use MOM_sponge, only : init_sponge_diags, sponge_CS +use MOM_sum_output, only : write_energy, accumulate_net_input +use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS use MOM_ALE_sponge, only : init_ALE_sponge_diags, ALE_sponge_CS use MOM_thickness_diffuse, only : thickness_diffuse, thickness_diffuse_init, thickness_diffuse_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS @@ -279,6 +281,10 @@ module MOM character(len=120) :: IC_file !< A file into which the initial conditions are !! written in a new run if SAVE_INITIAL_CONDS is true. + integer :: nstep_tot = 0 !< The total number of dynamic timesteps taken + !! so far in this run segment + logical :: count_calls = .false. !< If true, count the calls to step_MOM, rather than the + !! number of dynamics steps in nstep_tot integer :: ntrunc !< number u,v truncations since last call to write_energy logical :: check_bad_surface_vals !< If true, scan surface state for ridiculous values. real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message @@ -326,6 +332,7 @@ module MOM type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() type(ALE_CS), pointer :: ALE_CSp => NULL() type(offline_transport_CS), pointer :: offline_CSp => NULL() + type(sum_output_CS), pointer :: sum_output_CSp => NULL() ! These are used for group halo updates. type(group_pass_type) :: pass_tau_ustar_psurf @@ -885,10 +892,14 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS endif call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other) + if (.not.CS%count_calls) CS%nstep_tot = CS%nstep_tot + 1 + if (showCallTree) call callTree_leave("DT cycles (step_MOM)") enddo ! complete the n loop + if (CS%count_calls) CS%nstep_tot = CS%nstep_tot + 1 + call cpu_clock_begin(id_clock_other) Itot_wt_ssh = 1.0/tot_wt_ssh @@ -912,6 +923,17 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, MS, CS call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) + ! Accumulate the surface fluxes for assessing conservation + if (fluxes%fluxes_used) & + call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, & + G, CS%sum_output_CSp) + + if (MS%t_dyn_rel_adv==0.0) & + call write_energy(MS%u, MS%v, MS%h, MS%tv, Time_local, & + CS%nstep_tot, G, GV, CS%sum_output_CSp, & + CS%tracer_flow_CSp, & + dt_forcing=set_time(int(floor(time_interval+0.5))) ) + call cpu_clock_end(id_clock_other) if (showCallTree) call callTree_leave("step_MOM()") @@ -1352,9 +1374,11 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, MS end subroutine step_offline !> This subroutine initializes MOM. -subroutine initialize_MOM(Time, param_file, dirs, MS, CS, restart_CSp, Time_in, & - offline_tracer_mode, input_restart_file, diag_ptr) +subroutine initialize_MOM(Time, Time_init, param_file, dirs, MS, CS, restart_CSp, & + Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & + count_calls) type(time_type), target, intent(inout) :: Time !< model time, set in this routine + type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(param_file_type), intent(out) :: param_file !< structure indicating paramater file to parse type(directories), intent(out) :: dirs !< structure with directory paths type(MOM_state_type), pointer :: MS !< pointer set in this routine to structure describing the MOM state @@ -1368,6 +1392,9 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, restart_CSp, Time_in, character(len=*),optional, intent(in) :: input_restart_file !< If present, name of restart file to read type(diag_ctrl), optional, pointer :: diag_ptr !< A pointer set in this routine to the diagnostic !! regulatory structure + logical, optional, intent(in) :: count_calls !< If true, nstep_tot counts the number of + !! calls to step_MOM instead of the number of + !! dynamics timesteps. ! local type(ocean_grid_type), pointer :: G => NULL() ! A pointer to a structure with metrics and related @@ -2244,6 +2271,11 @@ subroutine initialize_MOM(Time, param_file, dirs, MS, CS, restart_CSp, Time_in, endif if (CS%split) deallocate(eta) + CS%nstep_tot = 0 + if (present(count_calls)) CS%count_calls = count_calls + call MOM_sum_output_init(G, param_file, dirs%output_directory, & + CS%ntrunc, Time_init, CS%sum_output_CSp) + ! Flag whether to save initial conditions in finish_MOM_initialization() or not. CS%write_IC = save_IC .and. & .not.((dirs%input_filename(1:1) == 'r') .and. & @@ -2292,6 +2324,9 @@ subroutine finish_MOM_initialization(Time, dirs, MS, CS, fluxes, restart_CSp) deallocate(restart_CSp_tmp) endif + call write_energy(MS%u, MS%v, MS%h, MS%tv, Time, 0, G, GV, & + CS%sum_output_CSp, CS%tracer_flow_CSp) + call callTree_leave("finish_MOM_initialization()") call cpu_clock_end(id_clock_init) From 58705c199869cc8065cf96ea491c66cf2b5f6330 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 26 Jan 2018 14:11:44 -0800 Subject: [PATCH 158/170] Deprecate neutral_diffusion_diag_init The registration of neutral diffusion diagnostics has been moved to add_tracer_diagnostics in the tracer registry module. Temperature and salinity should retain their special CMOR attributes. For all content tendency diagnostics (both directional fluxes and convergence), the appropriate cell methods are applied. This needs to be tested to ensure that the output diagnostics are all the same. --- src/core/MOM.F90 | 7 +- src/tracer/MOM_neutral_diffusion.F90 | 188 +++------------------------ src/tracer/MOM_tracer_registry.F90 | 79 ++++++++--- 3 files changed, 80 insertions(+), 194 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 5b93f1a443..51652f68fa 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -105,7 +105,7 @@ module MOM use MOM_MEKE_types, only : MEKE_type use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts -use MOM_neutral_diffusion, only : neutral_diffusion_CS, neutral_diffusion_diag_init +use MOM_neutral_diffusion, only : neutral_diffusion_CS use MOM_obsolete_diagnostics, only : register_obsolete_diagnostics use MOM_open_boundary, only : OBC_registry_type, register_temp_salt_segments use MOM_open_boundary, only : open_boundary_register_restarts @@ -1825,12 +1825,12 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo tr_desc=CS%vd_T, registry_diags=.true., flux_nameroot='T', & flux_units='W m-2', flux_longname='Heat', & flux_scale=conv2watt, convergence_units='W m-2', & - convergence_scale=conv2watt, CMOR_tendname="opottemptend", diag_form=2) + convergence_scale=conv2watt, CMOR_tendname="opottemp", diag_form=2) call register_tracer(CS%tv%S, CS%tracer_Reg, param_file, dG%HI, GV, & tr_desc=CS%vd_S, registry_diags=.true., flux_nameroot='S', & flux_units=S_flux_units, flux_longname='Salt', & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & - convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendname="osalttend", diag_form=2) + convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendname="osalt", diag_form=2) endif if (associated(CS%OBC)) & call register_temp_salt_segments(GV, CS%OBC, CS%tv, CS%vd_T, CS%vd_S, param_file) @@ -2198,7 +2198,6 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call cpu_clock_end(id_clock_pass_init) call register_obsolete_diagnostics(param_file, CS%diag) - call neutral_diffusion_diag_init(Time, G, diag, CS%tv%C_p, CS%tracer_Reg, CS%neutral_diffusion_CSp) if (CS%use_frazil) then if (.not.query_initialized(CS%tv%frazil,"frazil",CS%restart_CSp)) & diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 7892dd333a..6dd47c0960 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -29,7 +29,6 @@ module MOM_neutral_diffusion public neutral_diffusion public neutral_diffusion_init -public neutral_diffusion_diag_init public neutral_diffusion_end public neutral_diffusion_calc_coeffs public neutral_diffusion_unit_tests @@ -72,11 +71,6 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: dRdS_i ! dRho/dS (kg/m3/ppt) at top edge type(diag_ctrl), pointer :: diag ! structure to regulate output - integer, allocatable, dimension(:) :: id_neutral_diff_tracer_conc_tend ! tracer concentration tendency - integer, allocatable, dimension(:) :: id_neutral_diff_tracer_cont_tend ! tracer content tendency - integer, allocatable, dimension(:) :: id_neutral_diff_tracer_cont_tend_2d ! k-summed tracer content tendency - integer, allocatable, dimension(:) :: id_neutral_diff_tracer_trans_x_2d ! k-summed ndiff zonal tracer transport - integer, allocatable, dimension(:) :: id_neutral_diff_tracer_trans_y_2d ! k-summed ndiff merid tracer transport real :: C_p ! heat capacity of seawater (J kg-1 K-1) @@ -208,142 +202,6 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, CS) end function neutral_diffusion_init -!> Diagnostic handles for neutral diffusion tendencies. -subroutine neutral_diffusion_diag_init(Time, G, diag, C_p, Reg, CS) - type(time_type),target, intent(in) :: Time !< Time structure - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(diag_ctrl), intent(in) :: diag !< Diagnostics control structure - type(tracer_registry_type), intent(in) :: Reg !< Tracer structure - real, intent(in) :: C_p !< Seawater heat capacity - type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure - - ! local - integer :: n,ntr - - if(.not. associated(CS)) return - - ntr = Reg%ntr - CS%C_p = C_p - - allocate(CS%id_neutral_diff_tracer_conc_tend(ntr)) - allocate(CS%id_neutral_diff_tracer_cont_tend(ntr)) - allocate(CS%id_neutral_diff_tracer_cont_tend_2d(ntr)) - allocate(CS%id_neutral_diff_tracer_trans_x_2d(ntr)) - allocate(CS%id_neutral_diff_tracer_trans_y_2d(ntr)) - CS%id_neutral_diff_tracer_conc_tend(:) = -1 - CS%id_neutral_diff_tracer_cont_tend(:) = -1 - CS%id_neutral_diff_tracer_cont_tend_2d(:) = -1 - CS%id_neutral_diff_tracer_trans_x_2d(:) = -1 - CS%id_neutral_diff_tracer_trans_y_2d(:) = -1 - - do n=1,ntr - - if(trim(Reg%Tr(n)%name) == 'T') then - - CS%id_neutral_diff_tracer_conc_tend(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_conc_tendency_'//trim(Reg%Tr(n)%name), diag%axesTL, Time, & - 'Neutral diffusion tracer concentration tendency for '//trim(Reg%Tr(n)%name),& - 'degC s-1') - - CS%id_neutral_diff_tracer_cont_tend(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_cont_tendency_'//trim(Reg%Tr(n)%name), diag%axesTL, Time, & - 'Neutral diffusion tracer content tendency for '//trim(Reg%Tr(n)%name), & - 'W m-2',cmor_field_name='opottemppmdiff', & - cmor_standard_name= & - 'tendency_of_sea_water_potential_temperature_expressed_as_heat_content_due_to_parameterized_mesocale_diffusion', & - cmor_long_name = & - 'Tendency of sea water potential temperature expressed as heat content due to parameterized mesocale diffusion', & - v_extensive=.true.) - - CS%id_neutral_diff_tracer_cont_tend_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_cont_tendency_2d_'//trim(Reg%Tr(n)%name), diag%axesT1, Time, & - 'Depth integrated neutral diffusion tracer content tendency for '//trim(Reg%Tr(n)%name), & - 'W m-2',cmor_field_name='opottemppmdiff_2d', & - cmor_standard_name= & - 'tendency_of_sea_water_potential_temperature_expressed_as_heat_content_due_to_parameterized_mesocale_diffusion_depth_integrated',& - cmor_long_name = & - 'Tendency of sea water potential temperature expressed as heat content due to parameterized mesocale diffusion depth integrated') - - CS%id_neutral_diff_tracer_trans_x_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_trans_x_2d_'//trim(Reg%Tr(n)%name), diag%axesCu1, Time, & - 'Depth integrated neutral diffusion zonal tracer transport for '//trim(Reg%Tr(n)%name),& - 'W') - - CS%id_neutral_diff_tracer_trans_y_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_trans_y_2d_'//trim(Reg%Tr(n)%name), diag%axesCv1, Time, & - 'Depth integrated neutral diffusion merid tracer transport for '//trim(Reg%Tr(n)%name),& - 'W') - - elseif(trim(Reg%Tr(n)%name) == 'S') then - - CS%id_neutral_diff_tracer_conc_tend(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_conc_tendency_'//trim(Reg%Tr(n)%name), diag%axesTL, Time, & - 'Neutral diffusion tracer concentration tendency for '//trim(Reg%Tr(n)%name),& - 'tracer concentration * s-1') - - CS%id_neutral_diff_tracer_cont_tend(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_cont_tendency_'//trim(Reg%Tr(n)%name), diag%axesTL, Time, & - 'Neutral diffusion tracer content tendency for '//trim(Reg%Tr(n)%name), & - 'kg m-2 s-1',cmor_field_name='osaltpmdiff', & - cmor_standard_name= & - 'tendency_of_sea_water_salinity_expressed_as_salt_content_due_to_parameterized_mesocale_diffusion', & - cmor_long_name = & - 'Tendency of sea water salinity expressed as salt content due to parameterized mesocale diffusion', & - v_extensive=.true.) - - CS%id_neutral_diff_tracer_cont_tend_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_cont_tendency_2d_'//trim(Reg%Tr(n)%name), diag%axesT1, Time, & - 'Depth integrated neutral diffusion tracer content tendency for '//trim(Reg%Tr(n)%name), & - 'kg m-2 s-1',cmor_field_name='osaltpmdiff_2d', & - cmor_standard_name= & - 'tendency_of_sea_water_salinity_expressed_as_salt_content_due_to_parameterized_mesocale_diffusion_depth_integrated',& - cmor_long_name = & - 'Tendency of sea water salinity expressed as salt content due to parameterized mesocale diffusion depth integrated') - - CS%id_neutral_diff_tracer_trans_x_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_trans_x_2d_'//trim(Reg%Tr(n)%name), diag%axesCu1, Time, & - 'Depth integrated neutral diffusion zonal tracer transport for '//trim(Reg%Tr(n)%name),& - 'kg s-1') - - CS%id_neutral_diff_tracer_trans_y_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_trans_y_2d_'//trim(Reg%Tr(n)%name), diag%axesCv1, Time, & - 'Depth integrated neutral diffusion merid tracer transport for '//trim(Reg%Tr(n)%name),& - 'kg s-1') - - else - - CS%id_neutral_diff_tracer_conc_tend(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_conc_tendency_'//trim(Reg%Tr(n)%name), diag%axesTL, Time, & - 'Neutral diffusion tracer concentration tendency for '//trim(Reg%Tr(n)%name),& - 'tracer concentration * m-2 s-1') - - CS%id_neutral_diff_tracer_cont_tend(n) = register_diag_field('ocean_model',& - 'ndiff_tracer_cont_tendency_'//trim(Reg%Tr(n)%name), diag%axesTL, Time, & - 'Neutral diffusion tracer content tendency for '//trim(Reg%Tr(n)%name), & - 'tracer content * m-2 s-1', v_extensive=.true.) - - CS%id_neutral_diff_tracer_cont_tend_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_cont_tendency_2d_'//trim(Reg%Tr(n)%name), diag%axesTL, Time, & - 'Depth integrated neutral diffusion tracer content tendency for '//trim(Reg%Tr(n)%name),& - 'tracer content * m-2 s-1') - - CS%id_neutral_diff_tracer_trans_x_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_trans_x_2d_'//trim(Reg%Tr(n)%name), diag%axesCu1, Time, & - 'Depth integrated neutral diffusion zonal tracer transport for '//trim(Reg%Tr(n)%name),& - 'kg s-1') - - CS%id_neutral_diff_tracer_trans_y_2d(n) = register_diag_field('ocean_model', & - 'ndiff_tracer_trans_y_2d_'//trim(Reg%Tr(n)%name), diag%axesCv1, Time, & - 'Depth integrated neutral diffusion merid tracer transport for '//trim(Reg%Tr(n)%name),& - 'kg s-1') - - endif - - enddo - -end subroutine neutral_diffusion_diag_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, EOS, CS) @@ -499,7 +357,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: i, j, k, m, ks, nk - real :: ppt2mks, Idt, convert + real :: Idt real :: h_neglect, h_neglect_edge !### Try replacing both of these with GV%H_subroundoff @@ -513,20 +371,10 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) tracer => Reg%Tr(m) ! for diagnostics - if(CS%id_neutral_diff_tracer_conc_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0 .or. & - CS%id_neutral_diff_tracer_trans_x_2d(m) > 0 .or. & - CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then - ppt2mks = 0.001 + if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & + tracer%id_dfx_2d > 0 .or. tracer%id_dfy_2d > 0) then Idt = 1.0/dt tendency(:,:,:) = 0.0 - tendency_2d(:,:) = 0.0 - trans_x_2d(:,:) = 0.0 - trans_y_2d(:,:) = 0.0 - convert = 1.0 - if(trim(tracer%name) == 'T') convert = CS%C_p * GV%H_to_kg_m2 - if(trim(tracer%name) == 'S') convert = ppt2mks * GV%H_to_kg_m2 endif uFlx(:,:,:) = 0. @@ -576,9 +424,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) enddo - if(CS%id_neutral_diff_tracer_conc_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend(m) > 0 .or. & - CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0 ) then + if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then do k = 1, GV%ke tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt enddo @@ -587,60 +433,60 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) endif enddo ; enddo - ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(CS%id_neutral_diff_tracer_trans_x_2d(m) > 0) then + if(tracer%id_dfx_2d > 0) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec trans_x_2d(I,j) = 0. if (G%mask2dCu(I,j)>0.) then do ks = 1,CS%nsurf-1 ; trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) enddo - trans_x_2d(I,j) = trans_x_2d(I,j) * Idt * convert + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt endif enddo ; enddo - call post_data(CS%id_neutral_diff_tracer_trans_x_2d(m), trans_x_2d(:,:), CS%diag) + call post_data(tracer%id_dfx_2d, trans_x_2d(:,:), CS%diag) endif ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(CS%id_neutral_diff_tracer_trans_y_2d(m) > 0) then + if(tracer%id_dfy_2d > 0) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec trans_y_2d(i,J) = 0. if (G%mask2dCv(i,J)>0.) then do ks = 1,CS%nsurf-1 ; trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) enddo - trans_y_2d(i,J) = trans_y_2d(i,J) * Idt * convert + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt endif enddo ; enddo - call post_data(CS%id_neutral_diff_tracer_trans_y_2d(m), trans_y_2d(:,:), CS%diag) + call post_data(tracer%id_dfy_2d, trans_y_2d(:,:), CS%diag) endif ! post tendency of tracer content - if(CS%id_neutral_diff_tracer_cont_tend(m) > 0) then - call post_data(CS%id_neutral_diff_tracer_cont_tend(m), tendency(:,:,:)*convert, CS%diag) + if(tracer%id_dfxy_cont > 0) then + call post_data(tracer%id_dfxy_cont, tendency(:,:,:), CS%diag) endif ! post depth summed tendency for tracer content - if(CS%id_neutral_diff_tracer_cont_tend_2d(m) > 0) then + if(tracer%id_dfxy_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(CS%id_neutral_diff_tracer_cont_tend_2d(m), tendency_2d(:,:)*convert, CS%diag) + call post_data(tracer%id_dfxy_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(CS%id_neutral_diff_tracer_conc_tend(m) > 0) then + if(tracer%id_dfxy_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(CS%id_neutral_diff_tracer_conc_tend(m), tendency, CS%diag) + call post_data(tracer%id_dfxy_conc, tendency, CS%diag) endif enddo ! Loop over tracer registry diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 44ffb1840c..29bf9d27a5 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -55,8 +55,15 @@ module MOM_tracer_registry !! in units of (conc * m3/s or conc * kg/s) real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux !! in units of (conc * m3/s or conc * kg/s) + real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux + !! in units of (conc * m3/s or conc * kg/s) + real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux + !! in units of (conc * m3/s or conc * kg/s) real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes + real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes + real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes + !! expressed as a change in concentration real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous !! timestep used for diagnostics real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array @@ -96,6 +103,7 @@ module MOM_tracer_registry integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_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 integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 integer :: id_tr_vardec = -1 end type tracer_type @@ -379,6 +387,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ cmorname = Tr%cmor_name ; cmor_longname = Tr%cmor_longname shortnm = Tr%flux_nameroot flux_longname = Tr%flux_longname + print *, name if (len_trim(cmor_longname) == 0) cmor_longname = longname if (len_trim(Tr%flux_units) > 0) then ; flux_units = Tr%flux_units @@ -401,29 +410,29 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ if (Tr%diag_form == 1) then Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & - trim(flux_units)) + trim(flux_units), v_extensive = .true., y_cell_method = 'sum') Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & - trim(flux_units)) + trim(flux_units), v_extensive = .true., x_cell_method = 'sum') Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & - trim(flux_units)) + 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" , & - trim(flux_units)) + 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), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale) + flux_units, v_extensive=.true., conversion=Tr%flux_scale, y_cell_method = 'sum') Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, "Advective (by residual mean) Meridional Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale) + flux_units, v_extensive=.true., conversion=Tr%flux_scale, x_cell_method = 'sum') Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_diffx", & diag%axesCuL, Time, "Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, v_extensive=.true., conversion=Tr%flux_scale) + flux_units, v_extensive=.true., conversion=Tr%flux_scale, y_cell_method = 'sum') 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) + 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) @@ -433,19 +442,19 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & "Vertically Integrated Advective Zonal Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale) + flux_units, conversion=Tr%flux_scale, y_cell_method = 'sum') Tr%id_ady_2d = register_diag_field("ocean_model", trim(shortnm)//"_ady_2d", & diag%axesCv1, Time, & "Vertically Integrated Advective Meridional Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale) + flux_units, conversion=Tr%flux_scale, x_cell_method = 'sum') Tr%id_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffx_2d", & diag%axesCu1, Time, & "Vertically Integrated Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale) + flux_units, conversion=Tr%flux_scale, y_cell_method = 'sum') Tr%id_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_diffy_2d", & diag%axesCv1, Time, & "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & - flux_units, conversion=Tr%flux_scale) + 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) @@ -456,11 +465,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ diag%axesTL, Time, & 'Horizontal convergence of residual mean advective fluxes of '//& trim(lowercase(flux_longname)), conv_units, v_extensive=.true., & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum') Tr%id_adv_xy_2d = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy_2d", & diag%axesT1, Time, & 'Vertical sum of horizontal convergence of residual mean advective fluxes of '//& - trim(lowercase(flux_longname)), conv_units, conversion=Tr%conv_scale) + trim(lowercase(flux_longname)), conv_units, conversion=Tr%conv_scale, & + x_cell_method = 'sum', y_cell_method = 'sum') if ((Tr%id_adv_xy > 0) .or. (Tr%id_adv_xy_2d > 0)) & call safe_alloc_ptr(Tr%advection_xy,isd,ied,jsd,jed,nz) @@ -475,26 +485,57 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ enddo ; enddo ; enddo endif + ! 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), & + conv_units, conversion = Tr%conv_scale, 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"// & + "tendency for "//trim(shortnm), conv_units, conversion = Tr%conv_scale, & + 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' + 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", conv_units, & + conversion = Tr%conv_scale, cmor_field_name = trim(Tr%cmor_tendname)//'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' + 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", & + conv_units, conversion = Tr%conv_scale, cmor_field_name=trim(Tr%cmor_tendname)//'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') + endif + Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & + diag%axesTL, Time, "Lateral (neutral) tracer concentration tendency for", units//' s-1') + var_lname = "Net time tendency for "//lowercase(flux_longname) if (len_trim(Tr%cmor_tendname) == 0) then Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & diag%axesTL, Time, var_lname, conv_units, & - v_extensive=.true.) + v_extensive=.true., x_cell_method = 'sum', y_cell_method = 'sum') Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & - diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units) + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & + x_cell_method = 'sum', y_cell_method = 'sum') else cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//trim(flux_longname)//" Content" Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & diag%axesTL, Time, var_lname, conv_units, & - cmor_field_name=Tr%cmor_tendname, & + cmor_field_name=trim(Tr%cmor_tendname)//"tend", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - v_extensive=.true., conversion=Tr%conv_scale) + v_extensive=.true., conversion=Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum') cmor_var_lname = trim(cmor_var_lname)//" Vertical Sum" Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & cmor_field_name=trim(Tr%cmor_tendname)//"_2d", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum') endif if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then call safe_alloc_ptr(Tr%Trxh_prev,isd,ied,jsd,jed,nz) From b8c358ed48ed680e211a149ec78539a1e8726eba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 28 Jan 2018 03:14:37 -0500 Subject: [PATCH 159/170] +Made MOM_control_struct opaque Eliminated the external use of elements from the MOM_control_struct in the driver routines, and made the MOM_control_struct private. Doing so also involved adding a new optional argument to initialize_MOM returning a pointer to the tracer_flow_control_CS for use by the driver in initializing the tracer surface forcing. All answers are bitwise identical, but the change in types is not backward compatible and requires the changes to the top-level drivers. --- config_src/coupled_driver/ocean_model_MOM.F90 | 13 ++++++-- config_src/mct_driver/ocn_comp_mct.F90 | 12 ++++++-- config_src/solo_driver/MOM_driver.F90 | 29 ++++++++++-------- src/core/MOM.F90 | 30 ++++++++++--------- 4 files changed, 52 insertions(+), 32 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 110ccd8769..250d554361 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -165,6 +165,13 @@ module ocean_model_mod real :: press_to_z !< A conversion factor between pressure and ocean !! depth in m, usually 1/(rho_0*g), in m Pa-1. real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. + logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode + !! with the barotropic and baroclinic dynamics, thermodynamics, + !! etc. stepped forward integrated in time. + !! If true, all of the above are bypassed with all + !! fields necessary to integrate only the tracer advection + !! and diffusion equation read in from files stored from + !! a previous integration of the prognostic model. type(directories) :: dirs !< A structure containing several relevant directory paths. type(mech_forcing) :: forces !< A structure with the driving mechanical surface forces @@ -245,7 +252,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) character(len=48) :: stagger integer :: secs, days type(param_file_type) :: param_file !< A structure to parse for run-time parameters - logical :: offline_tracer_mode, use_temperature + logical :: use_temperature type(time_type) :: dt_geometric, dt_savedays, dt_from_base call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") @@ -261,7 +268,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=offline_tracer_mode, & + OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true.) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV OS%C_p = OS%MSp%tv%C_p @@ -522,7 +529,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time - if(OS%MOM_Csp%offline_tracer_mode) then + if(OS%offline_tracer_mode) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MSp, OS%MOM_CSp) else call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MSp, OS%MOM_CSp) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index e4772af614..e5468b770a 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -312,6 +312,13 @@ module ocn_comp_mct real :: press_to_z !< A conversion factor between pressure and ocean !! depth in m, usually 1/(rho_0*g), in m Pa-1. real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. + logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode + !! with the barotropic and baroclinic dynamics, thermodynamics, + !! etc. stepped forward integrated in time. + !! If true, all of the above are bypassed with all + !! fields necessary to integrate only the tracer advection + !! and diffusion equation read in from files stored from + !! a previous integration of the prognostic model. type(directories) :: dirs !< A structure containing several relevant directory paths. type(forcing) :: fluxes !< A structure containing pointers to !! the ocean forcing fields. @@ -810,7 +817,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i character(len=48) :: stagger integer :: secs, days type(param_file_type) :: param_file !< A structure to parse for run-time parameters - logical :: offline_tracer_mode call callTree_enter("ocean_model_init(), ocn_comp_mct.F90") if (associated(OS)) then @@ -825,7 +831,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MSp, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=offline_tracer_mode, & + OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, diag_ptr=OS%diag, & count_calls=.true.) OS%grid => OS%MSp%G ; OS%GV => OS%MSp%GV @@ -1766,7 +1772,7 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time - if(OS%MOM_Csp%offline_tracer_mode) then + if(OS%offline_tracer_mode) then call step_offline(OS%fluxes, OS%state, Time1, time_step, OS%MSp, OS%MOM_CSp) else call step_MOM(OS%fluxes, OS%state, Time1, time_step, OS%MSp, OS%MOM_CSp) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 66e2f5d19b..62a0dc12bf 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -53,6 +53,7 @@ program MOM_main use MOM_time_manager, only : increment_date, set_calendar_type, month_name use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS use MOM_time_manager, only : NO_CALENDAR + use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init @@ -89,7 +90,7 @@ program MOM_main ! This is .true. if incremental restart files may be saved. logical :: permit_incr_restart = .true. - integer :: n + integer :: ns ! nmax is the number of iterations after which to stop so that the ! simulation does not exceed its CPU time limit. nmax is determined by @@ -167,11 +168,14 @@ program MOM_main type(MOM_control_struct), pointer :: MOM_CSp => NULL() type(MOM_state_type), pointer :: MSp => NULL() + !> A pointer to the tracer flow control structure. + type(tracer_flow_control_CS), pointer :: & + tracer_flow_CSp => NULL() !< A pointer to the tracer flow control structure type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure + restart_CSp => NULL() !< A pointer to the restart control structure !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure @@ -282,13 +286,14 @@ program MOM_main Time = segment_start_time call initialize_MOM(Time, Start_time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & segment_start_time, offline_tracer_mode=offline_tracer_mode, & - diag_ptr=diag) + diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp) else ! In this case, the segment starts at a time read from the MOM restart file ! or left as Start_time by MOM_initialize. Time = Start_time call initialize_MOM(Time, Start_time, param_file, dirs, MSp, MOM_CSp, restart_CSp, & - offline_tracer_mode=offline_tracer_mode, diag_ptr=diag) + offline_tracer_mode=offline_tracer_mode, diag_ptr=diag, & + tracer_flow_CSp=tracer_flow_CSp) endif fluxes%C_p = MSp%tv%C_p ! Copy the heat capacity for consistency. @@ -301,7 +306,7 @@ program MOM_main MSp%ave_ssh, grid, GV, MSp, MOM_CSp) call surface_forcing_init(Time, grid, param_file, diag, & - surface_forcing_CSp, MOM_CSp%tracer_flow_CSp) + surface_forcing_CSp, tracer_flow_CSp) call callTree_waypoint("done surface_forcing_init") call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & @@ -424,9 +429,9 @@ program MOM_main call cpu_clock_begin(mainClock) !begin main loop - n = 1 - do while ((n < nmax) .and. (Time < Time_end)) - call callTree_enter("Main loop, MOM_driver.F90",n) + ns = 1 + do while ((ns < nmax) .and. (Time < Time_end)) + call callTree_enter("Main loop, MOM_driver.F90",ns) ! Set the forcing for the next steps. if (.not. offline_tracer_mode) then @@ -447,7 +452,7 @@ program MOM_main fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = time_step - if (n==1) then + if (ns==1) then call finish_MOM_initialization(Time, dirs, MSp, MOM_CSp, fluxes, restart_CSp) endif @@ -479,8 +484,8 @@ program MOM_main endif Time = Master_Time - if (cpu_steps > 0) then ; if (MOD(n, cpu_steps) == 0) then - call write_cputime(Time, n+ntstep-1, nmax, write_CPU_CSp) + if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then + call write_cputime(Time, ns+ntstep-1, nmax, write_CPU_CSp) endif ; endif call enable_averaging(time_step, Time, diag) @@ -522,7 +527,7 @@ program MOM_main restart_time = restart_time + restint endif - n = n + ntstep + ns = ns + ntstep call callTree_leave("Main loop") enddo diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c460c6e7f4..c67c99a2c6 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -194,7 +194,7 @@ module MOM !> Control structure for this module -type, public :: MOM_control_struct +type, public :: MOM_control_struct ; private type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing type(vertvisc_type) :: visc !< structure containing vertical viscosities, !! bottom drag viscosities, and related fields @@ -1376,7 +1376,7 @@ end subroutine step_offline !> This subroutine initializes MOM. subroutine initialize_MOM(Time, Time_init, param_file, dirs, MS, CS, restart_CSp, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & - count_calls) + count_calls, tracer_flow_CSp) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(param_file_type), intent(out) :: param_file !< structure indicating paramater file to parse @@ -1388,14 +1388,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, MS, CS, restart_CSp !! be used for MOM. type(time_type), optional, intent(in) :: Time_in !< time passed to MOM_initialize_state when !! model is not being started from a restart file - logical, optional, intent(out) :: offline_tracer_mode !< True if tracers are being run offline + logical, optional, intent(out) :: offline_tracer_mode !< True is returned if tracers are being run offline character(len=*),optional, intent(in) :: input_restart_file !< If present, name of restart file to read type(diag_ctrl), optional, pointer :: diag_ptr !< A pointer set in this routine to the diagnostic !! regulatory structure + type(tracer_flow_control_CS), & + optional, pointer :: tracer_flow_CSp !< A pointer set in this routine to + !! the tracer flow control structure. logical, optional, intent(in) :: count_calls !< If true, nstep_tot counts the number of !! calls to step_MOM instead of the number of !! dynamics timesteps. - ! local type(ocean_grid_type), pointer :: G => NULL() ! A pointer to a structure with metrics and related type(hor_index_type) :: HI ! A hor_index_type for array extents @@ -1544,19 +1546,19 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, MS, CS, restart_CSp "the gravity wave adjustment to h. This is a fragile feature and\n"//& "thus undocumented.", default=.true., do_not_log=.true. ) call get_param(param_file, "MOM", "ADVECT_TS", CS%advect_TS , & - "If True, advect temperature and salinity horizontally\n"//& + "If True, advect temperature and salinity horizontally \n"//& "If False, T/S are registered for advection.\n"//& - "This is intended only to be used in offline tracer mode.", & - "and is by default false in that case", & + "This is intended only to be used in offline tracer mode \n"//& + "and is by default false in that case.", & do_not_log = .true., default=.true. ) - if (present(offline_tracer_mode)) then ! Only read this parameter in solo mode + if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & "If true, barotropic and baroclinic dynamics, thermodynamics\n"//& "are all bypassed with all the fields necessary to integrate\n"//& "the tracer advection and diffusion equation are read in from\n"//& "files stored from a previous integration of the prognostic model.\n"//& "NOTE: This option only used in the ocean_solo_driver.", default=.false.) - if(CS%offline_tracer_mode) then + if (CS%offline_tracer_mode) then call get_param(param_file, "MOM", "ADVECT_TS", CS%advect_TS , & "If True, advect temperature and salinity horizontally\n"//& "If False, T/S are registered for advection.\n"//& @@ -2214,13 +2216,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, MS, CS, restart_CSp call tracer_flow_control_init(.not.new_sim, Time, G, GV, MS%h, param_file, & CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & CS%ALE_sponge_CSp, CS%diag_to_Z_CSp, MS%tv) - + if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp ! If running in offline tracer mode, initialize the necessary control structure and ! parameters - if(present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode + if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode - if(CS%offline_tracer_mode) then + if (CS%offline_tracer_mode) then ! Setup some initial parameterizations and also assign some of the subtypes call offline_transport_init(param_file, CS%offline_CSp, CS%diabatic_CSp, G, GV) call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & @@ -2429,7 +2431,7 @@ subroutine MOM_timing_init(CS) id_clock_diagnostics = cpu_clock_id('(Ocean collective diagnostics)', grain=CLOCK_MODULE) id_clock_Z_diag = cpu_clock_id('(Ocean Z-space diagnostics)', grain=CLOCK_MODULE) id_clock_ALE = cpu_clock_id('(Ocean ALE)', grain=CLOCK_MODULE) - if(CS%offline_tracer_mode) then + if (CS%offline_tracer_mode) then id_clock_offline_tracer = cpu_clock_id('Ocean offline tracers', grain=CLOCK_SUBCOMPONENT) endif @@ -3166,7 +3168,7 @@ subroutine MOM_end(MS, CS) call tracer_registry_end(CS%tracer_Reg) call tracer_flow_control_end(CS%tracer_flow_CSp) - if(CS%offline_tracer_mode) then + if (CS%offline_tracer_mode) then call offline_transport_end(CS%offline_CSp) endif From e250e10c8931f810ccbfa2d99a7bde14f31b1284 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 28 Jan 2018 03:50:24 -0500 Subject: [PATCH 160/170] Removed a trailing blank in a comment --- 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 c67c99a2c6..26f7b90393 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -284,7 +284,7 @@ module MOM integer :: nstep_tot = 0 !< The total number of dynamic timesteps taken !! so far in this run segment logical :: count_calls = .false. !< If true, count the calls to step_MOM, rather than the - !! number of dynamics steps in nstep_tot + !! number of dynamics steps in nstep_tot integer :: ntrunc !< number u,v truncations since last call to write_energy logical :: check_bad_surface_vals !< If true, scan surface state for ridiculous values. real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message From 11c2a9197c5c93963effffb65abae5cd9723ce51 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 29 Jan 2018 09:38:33 -0800 Subject: [PATCH 161/170] Move ALE tendencies to tracer registry As with the advective and diffusive tendencies, the registration of tracer tendencies associated with the ALE remapping has been moved to the registry and is available for all tracers. --- src/ALE/MOM_ALE.F90 | 157 ++++++----------------------- src/core/MOM.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 20 ++++ 3 files changed, 50 insertions(+), 129 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index e456eb8dcb..98a0384993 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -41,7 +41,7 @@ module MOM_ALE use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme use MOM_remapping, only : remapping_CS, dzFromH1H2 use MOM_string_functions, only : uppercase, extractWord, extract_integer -use MOM_tracer_registry, only : tracer_registry_type, MOM_tracer_chkinv +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : get_thickness_units, verticalGrid_type @@ -93,7 +93,6 @@ module MOM_ALE logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. logical :: show_call_tree !< For debugging - real :: C_p !< seawater heat capacity (J/(kg deg C)) ! for diagnostics type(diag_ctrl), pointer :: diag !< structure to regulate output @@ -271,35 +270,14 @@ subroutine ALE_init( param_file, GV, max_depth, CS) end subroutine ALE_init !> Initialize diagnostics for the ALE module. -subroutine ALE_register_diags(Time, G, GV, diag, C_p, Reg, CS) +subroutine ALE_register_diags(Time, G, GV, diag, CS) type(time_type),target, intent(in) :: Time !< Time structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(diag_ctrl), target, intent(in) :: diag !< Diagnostics control structure - real, intent(in) :: C_p !< seawater heat capacity (J/(kg deg C)) - type(tracer_registry_type), pointer :: Reg !< Tracer registry type(ALE_CS), pointer :: CS !< Module control structure - integer :: m, ntr, nsize - - if (associated(Reg)) then - ntr = Reg%ntr - else - ntr = 0 - endif - nsize = max(1,ntr) - CS%diag => diag - CS%C_p = C_p - - allocate(CS%id_tracer_remap_tendency(nsize)) - allocate(CS%id_Htracer_remap_tendency(nsize)) - allocate(CS%id_Htracer_remap_tendency_2d(nsize)) - allocate(CS%do_tendency_diag(nsize)) - CS%do_tendency_diag(:) = .false. - CS%id_tracer_remap_tendency(:) = -1 - CS%id_Htracer_remap_tendency(:) = -1 - CS%id_Htracer_remap_tendency_2d(:) = -1 ! These diagnostics of the state variables before ALE are useful for ! debugging the ALE code. @@ -319,52 +297,6 @@ subroutine ALE_register_diags(Time, G, GV, diag, C_p, Reg, CS) CS%id_dzRegrid = register_diag_field('ocean_model','dzRegrid',diag%axesTi,Time, & 'Change in interface height due to ALE regridding', 'm') - if (ntr > 0) then - do m=1,ntr - if (trim(Reg%Tr(m)%name) == 'T') then - - CS%id_tracer_remap_tendency(m) = register_diag_field('ocean_model', & - trim(Reg%Tr(m)%name)//'_tendency_vert_remap', diag%axesTL, Time, & - 'Tendency from vertical remapping for tracer concentration '//trim(Reg%Tr(m)%name),& - 'degC s-1') - - CS%id_Htracer_remap_tendency(m) = register_diag_field('ocean_model',& - trim(Reg%Tr(m)%name)//'h_tendency_vert_remap', diag%axesTL, Time, & - 'Tendency from vertical remapping for heat', & - 'W m-2',v_extensive=.true.) - - CS%id_Htracer_remap_tendency_2d(m) = register_diag_field('ocean_model',& - trim(Reg%Tr(m)%name)//'h_tendency_vert_remap_2d', diag%axesT1, Time, & - 'Vertical sum of tendency from vertical remapping for heat', & - 'W m-2') - - else - - CS%id_tracer_remap_tendency(m) = register_diag_field('ocean_model', & - trim(Reg%Tr(m)%name)//'_tendency_vert_remap', diag%axesTL, Time, & - 'Tendency from vertical remapping for tracer concentration '//trim(Reg%Tr(m)%name),& - 'tracer concentration * s-1') - - CS%id_Htracer_remap_tendency(m) = register_diag_field('ocean_model', & - trim(Reg%Tr(m)%name)//'h_tendency_vert_remap', diag%axesTL, Time, & - 'Tendency from vertical remapping for tracer content '//trim(Reg%Tr(m)%name),& - 'kg m-2 s-1',v_extensive=.true.) - - CS%id_Htracer_remap_tendency_2d(m) = register_diag_field('ocean_model', & - trim(Reg%Tr(m)%name)//'h_tendency_vert_remap_2d', diag%axesT1, Time, & - 'Vertical sum of tendency from vertical remapping for tracer content '//trim(Reg%Tr(m)%name),& - 'kg m-2 s-1') - - endif - - if (CS%id_tracer_remap_tendency(m) > 0) CS%do_tendency_diag(m) = .true. - if (CS%id_Htracer_remap_tendency(m) > 0) CS%do_tendency_diag(m) = .true. - if (CS%id_Htracer_remap_tendency_2d(m) > 0) CS%do_tendency_diag(m) = .true. - - enddo ! m loop over tracers - - endif ! ntr > 0 - end subroutine ALE_register_diags !> Crudely adjust (initial) grid for integrity. @@ -840,6 +772,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(GV%ke) :: h2 real :: h_neglect, h_neglect_edge logical :: show_call_tree + type(tracer_type), pointer :: Tr => NULL() show_call_tree = .false. if (present(debug)) show_call_tree = debug @@ -869,10 +802,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, endif if (present(dt)) then - work_conc(:,:,:) = 0.0 - work_cont(:,:,:) = 0.0 - work_2d(:,:) = 0.0 - Idt = 1.0/dt + Idt = 1.0/dt endif ! Remap tracer @@ -880,7 +810,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, if (show_call_tree) call callTree_waypoint("remapping tracers (remap_all_state_vars)") !$OMP parallel do default(shared) private(h1,h2,u_column) do m=1,ntr ! For each tracer - + Tr => Reg%Tr(m) do j = G%jsc,G%jec do i = G%isc,G%iec @@ -889,23 +819,25 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Build the start and final grids h1(:) = h_old(i,j,:) h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Reg%Tr(m)%t(i,j,:), nz, h2, & + call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & u_column, h_neglect, h_neglect_edge) ! Intermediate steps for tendency of tracer concentration and tracer content. - ! Note: do not merge the two if-tests, since do_tendency_diag(:) is not - ! allocated during the time=0 initialization call to this routine. if (present(dt)) then - if (CS_ALE%do_tendency_diag(m)) then + if (Tr%id_remap_conc>0) then + do k=1,GV%ke + work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k) ) * Idt + enddo + endif + if (Tr%id_remap_cont>0. .or. Tr%id_remap_cont_2d>0) then do k=1,GV%ke - work_conc(i,j,k) = (u_column(k) - Reg%Tr(m)%t(i,j,k) ) * Idt - work_cont(i,j,k) = (u_column(k)*h2(k) - Reg%Tr(m)%t(i,j,k)*h1(k)) * Idt * GV%H_to_kg_m2 + work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt enddo endif endif ! update tracer concentration - Reg%Tr(m)%t(i,j,:) = u_column(:) + Tr%t(i,j,:) = u_column(:) endif @@ -914,53 +846,22 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! tendency diagnostics. - ! Note: do not merge the two if-tests if (present(dt)) and - ! if (CS_ALE%do_tendency_diag(m)). The reason is that - ! do_tendency_diag(:) is not allocated when this routine is called - ! during initialization (time=0). So need to keep the if-tests split. - if (present(dt)) then - if (CS_ALE%do_tendency_diag(m)) then - - if (CS_ALE%id_tracer_remap_tendency(m) > 0) then - call post_data(CS_ALE%id_tracer_remap_tendency(m), work_conc, CS_ALE%diag, alt_h = h_new) - endif - - if (CS_ALE%id_Htracer_remap_tendency(m) > 0 .or. CS_ALE%id_Htracer_remap_tendency_2d(m) > 0) then - if (trim(Reg%Tr(m)%name) == 'T') then - do k=1,GV%ke - do j = G%jsc,G%jec - do i = G%isc,G%iec - work_cont(i,j,k) = work_cont(i,j,k) * CS_ALE%C_p - enddo - enddo - enddo - elseif (trim(Reg%Tr(m)%name) == 'S') then - do k=1,GV%ke - do j = G%jsc,G%jec - do i = G%isc,G%iec - work_cont(i,j,k) = work_cont(i,j,k) * ppt2mks - enddo - enddo - enddo - endif - endif - - if (CS_ALE%id_Htracer_remap_tendency(m) > 0) then - call post_data(CS_ALE%id_Htracer_remap_tendency(m), work_cont, CS_ALE%diag, alt_h = h_new) - endif - if (CS_ALE%id_Htracer_remap_tendency_2d(m) > 0) then - do j = G%jsc,G%jec - do i = G%isc,G%iec - work_2d(i,j) = 0.0 - do k = 1,GV%ke - work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) - enddo - enddo + if (Tr%id_remap_conc > 0) then + call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag, alt_h = h_new) + endif + if (Tr%id_remap_cont > 0) then + call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag, alt_h = h_new) + endif + if (Tr%id_remap_cont_2d > 0) then + do j = G%jsc,G%jec + do i = G%isc,G%iec + work_2d(i,j) = 0.0 + do k = 1,GV%ke + work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) enddo - call post_data(CS_ALE%id_Htracer_remap_tendency_2d(m), work_2d, CS_ALE%diag) - endif - - endif + enddo + enddo + call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) endif enddo ! m=1,ntr diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 51652f68fa..dbffe3c11b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2156,7 +2156,7 @@ subroutine initialize_MOM(Time, param_file, dirs, CS, Time_in, offline_tracer_mo call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & CS%use_ALE_algorithm, CS%diag_to_Z_CSp) if (CS%use_ALE_algorithm) then - call ALE_register_diags(Time, G, GV, diag, CS%tv%C_p, CS%tracer_Reg, CS%ALE_CSp) + call ALE_register_diags(Time, G, GV, diag, CS%ALE_CSp) endif ! This subroutine initializes any tracer packages. diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 29bf9d27a5..7ffb82cc6d 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -104,6 +104,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_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 end type tracer_type @@ -552,6 +553,25 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ cmor_long_name=cmor_longname) endif + ! Vertical regridding/remapping tendencies + if (use_ALE .and. Tr%remap_tr) then + var_lname = "Vertical remapping tracer concentration tendency for "//trim(Reg%Tr(m)%name) + Tr%id_remap_conc= register_diag_field('ocean_model', & + trim(Tr%flux_nameroot)//'_tendency_vert_remap', diag%axesTL, Time, var_lname, & + trim(units)//'s-1') + + var_lname = "Vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) + Tr%id_remap_cont = register_diag_field('ocean_model', & + trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & + diag%axesTL, Time, var_lname, flux_units, v_extensive=.true., conversion = Tr%conv_scale) + + var_lname = "Vertical sum of verrtical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) + Tr%id_remap_cont_2d = register_diag_field('ocean_model', & + trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & + diag%axesT1, Time, var_lname, flux_units, conversion = Tr%conv_scale) + + endif + if (use_ALE .and. (Reg%ntr 0) unit2 = "("//trim(units)//")2" From f7d7daf615fd40d21bb8e04c054b4884f0814206 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 29 Jan 2018 10:13:40 -0800 Subject: [PATCH 162/170] Correct CMOR name for vertically integrated time tendency Changing the cmor_tendname prefix to just osalt or opottemp meant that the vertically integrated total time tendency needed to be updated as well --- src/tracer/MOM_tracer_registry.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 7ffb82cc6d..211c556b59 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -534,7 +534,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ cmor_var_lname = trim(cmor_var_lname)//" Vertical Sum" Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & - cmor_field_name=trim(Tr%cmor_tendname)//"_2d", & + cmor_field_name=trim(Tr%cmor_tendname)//"tend_2d", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & conversion=Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum') endif From 496ed59c17a992aa4bd213cda66358f16de0568e Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 29 Jan 2018 11:37:49 -0800 Subject: [PATCH 163/170] Remove cell methods from tendencies. I think I've convinced myself of the correct cell methods for various tracer-related diagnostics --- src/tracer/MOM_tracer_registry.F90 | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 211c556b59..bf17986b2a 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -466,12 +466,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ diag%axesTL, Time, & 'Horizontal convergence of residual mean advective fluxes of '//& trim(lowercase(flux_longname)), conv_units, v_extensive=.true., & - conversion=Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum') + conversion=Tr%conv_scale) Tr%id_adv_xy_2d = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy_2d", & diag%axesT1, Time, & 'Vertical sum of horizontal convergence of residual mean advective fluxes of '//& - trim(lowercase(flux_longname)), conv_units, conversion=Tr%conv_scale, & - x_cell_method = 'sum', y_cell_method = 'sum') + trim(lowercase(flux_longname)), conv_units, conversion=Tr%conv_scale) if ((Tr%id_adv_xy > 0) .or. (Tr%id_adv_xy_2d > 0)) & call safe_alloc_ptr(Tr%advection_xy,isd,ied,jsd,jed,nz) @@ -519,24 +518,22 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ var_lname = "Net time tendency for "//lowercase(flux_longname) if (len_trim(Tr%cmor_tendname) == 0) then Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & - diag%axesTL, Time, var_lname, conv_units, & - v_extensive=.true., x_cell_method = 'sum', y_cell_method = 'sum') + diag%axesTL, Time, var_lname, conv_units, v_extensive=.true.) Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & - diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & - x_cell_method = 'sum', y_cell_method = 'sum') + diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units) else cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//trim(flux_longname)//" Content" Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & diag%axesTL, Time, var_lname, conv_units, & cmor_field_name=trim(Tr%cmor_tendname)//"tend", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - v_extensive=.true., conversion=Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum') + v_extensive=.true., conversion=Tr%conv_scale) cmor_var_lname = trim(cmor_var_lname)//" Vertical Sum" Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units, & cmor_field_name=trim(Tr%cmor_tendname)//"tend_2d", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - conversion=Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum') + conversion=Tr%conv_scale) endif if ((Tr%id_trxh_tendency > 0) .or. (Tr%id_trxh_tendency_2d > 0)) then call safe_alloc_ptr(Tr%Trxh_prev,isd,ied,jsd,jed,nz) @@ -565,7 +562,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & diag%axesTL, Time, var_lname, flux_units, v_extensive=.true., conversion = Tr%conv_scale) - var_lname = "Vertical sum of verrtical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) + var_lname = "Vertical sum of vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont_2d = register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & diag%axesT1, Time, var_lname, flux_units, conversion = Tr%conv_scale) From 1af421b8db6748d9c74d8212394f9eae82d18428 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 30 Jan 2018 09:06:02 -0800 Subject: [PATCH 164/170] Removed a line intended for debugging --- src/tracer/MOM_tracer_registry.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index bf17986b2a..fd600df72c 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -388,7 +388,6 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ cmorname = Tr%cmor_name ; cmor_longname = Tr%cmor_longname shortnm = Tr%flux_nameroot flux_longname = Tr%flux_longname - print *, name if (len_trim(cmor_longname) == 0) cmor_longname = longname if (len_trim(Tr%flux_units) > 0) then ; flux_units = Tr%flux_units From eee373858a84ca53dfd45124c12277dec1caaeef Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 Jan 2018 15:08:58 -0500 Subject: [PATCH 165/170] Removed the other trailing blanks in a comment --- 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 26f7b90393..4253416e39 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -284,7 +284,7 @@ module MOM integer :: nstep_tot = 0 !< The total number of dynamic timesteps taken !! so far in this run segment logical :: count_calls = .false. !< If true, count the calls to step_MOM, rather than the - !! number of dynamics steps in nstep_tot + !! number of dynamics steps in nstep_tot integer :: ntrunc !< number u,v truncations since last call to write_energy logical :: check_bad_surface_vals !< If true, scan surface state for ridiculous values. real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message From 907bd422ea4f42601072deb93fc35ed4610234d8 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 31 Jan 2018 13:08:43 -0800 Subject: [PATCH 166/170] Initialize value in neutral_diffusion_aux The machep was being used without ever being defined (likely because the last update to neutral diffusion accidentally deleted a line). machep is intended to store the machine epsilon value for real variable types. --- src/tracer/MOM_neutral_diffusion_aux.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 7d10e8d575..09ed0c0e58 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -374,6 +374,8 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to real :: d, e, f, fa, fb, fc, m, p, q, r, s0, sa, sb, tol, machep real :: P_last + + machep = EPSILON(machep) if (CS%ref_pres>=0.) P_ref = CS%ref_pres delta_P = P_bot-P_top refine_nondim_position = min_bound From ebe25aff36b2eb6d29a6b2eceb6fb42e285e02cf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 Jan 2018 17:27:03 -0500 Subject: [PATCH 167/170] Initialize neutral_diffusion_CS%debug to .false. Initialized the debug element to .false. in the definition of neutral_diffusion_CS. The unit tests use the neutral_diffusion_CS without calling neutral_diffusion_init. The debug element was not being initialized in that case, and if it happened to be .true., some other uninitialized variables could cause a segmentation fault. With this change, all cases that worked (and all actual MOM6 test cases) give bitwise identical answers. --- 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 04c94fdc98..4e4da08451 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -43,7 +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 :: refine_position = .false. - logical :: debug + logical :: debug = .false. integer :: max_iter ! Maximum number of iterations if refine_position is defined real :: tolerance ! Convergence criterion representing difference from true neutrality real :: ref_pres ! Reference pressure, negative if using locally referenced neutral density From 668000308633f2fd8a4cc93c9910970a623a3dd7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 Jan 2018 18:50:50 -0500 Subject: [PATCH 168/170] Corrected tracer diagnostic metadata formatting Corrected formatting of longname and units metadata for some newly added tracer tendency diagnostics. All answers are bitwise identical, but there are minor changes to the available_diags files. --- src/tracer/MOM_tracer_registry.F90 | 53 ++++++++++++++++-------------- 1 file changed, 29 insertions(+), 24 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index fd600df72c..0a9c66897d 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -318,7 +318,7 @@ subroutine add_tracer_OBC_values(name, Reg, OBC_inflow, OBC_in_u, OBC_in_v) integer :: m - if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_OBC_values :"// & + if (.not. associated(Reg)) call MOM_error(FATAL, "add_tracer_OBC_values :"//& "register_tracer must be called before add_tracer_OBC_values") do m=1,Reg%ntr ; if (Reg%Tr(m)%name == trim(name)) exit ; enddo @@ -374,7 +374,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (.not. associated(Reg)) call MOM_error(FATAL, "register_tracer_diagnostics: "// & + if (.not. associated(Reg)) call MOM_error(FATAL, "register_tracer_diagnostics: "//& "register_tracer must be called before register_tracer_diagnostics") nTr_in = Reg%ntr @@ -486,33 +486,36 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ ! 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), & - conv_units, conversion = Tr%conv_scale, x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) + 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), & + conv_units, conversion=Tr%conv_scale, 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"// & - "tendency for "//trim(shortnm), conv_units, conversion = Tr%conv_scale, & + diag%axesT1, Time, "Depth integrated lateral or neutral diffusion tracer concentration "//& + "tendency for "//trim(shortnm), conv_units, conversion = Tr%conv_scale, & 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' - 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", conv_units, & - conversion = Tr%conv_scale, cmor_field_name = trim(Tr%cmor_tendname)//'pmdiff', & - cmor_long_name = trim(cmor_var_lname), cmor_standard_name = trim(cmor_long_std(cmor_var_lname)), & + cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//& + ' expressed as '//trim(lowercase(flux_longname))//& + ' content due to parameterized mesoscale 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), & + conv_units, conversion = Tr%conv_scale, cmor_field_name = trim(Tr%cmor_tendname)//'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' - 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", & - conv_units, conversion = Tr%conv_scale, cmor_field_name=trim(Tr%cmor_tendname)//'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_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, & + conversion=Tr%conv_scale, cmor_field_name=trim(Tr%cmor_tendname)//'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') endif Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & - diag%axesTL, Time, "Lateral (neutral) tracer concentration tendency for", units//' s-1') + diag%axesTL, Time, "Lateral (neutral) tracer concentration tendency for "//trim(shortnm), & + trim(units)//' s-1') var_lname = "Net time tendency for "//lowercase(flux_longname) if (len_trim(Tr%cmor_tendname) == 0) then @@ -521,7 +524,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ Tr%id_trxh_tendency_2d = register_diag_field('ocean_model', trim(shortnm)//'h_tendency_2d', & diag%axesT1, Time, "Vertical sum of "//trim(lowercase(var_lname)), conv_units) else - cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//trim(flux_longname)//" Content" + cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//& + trim(flux_longname)//" Content" Tr%id_trxh_tendency = register_diag_field('ocean_model', trim(shortnm)//'h_tendency', & diag%axesTL, Time, var_lname, conv_units, & cmor_field_name=trim(Tr%cmor_tendname)//"tend", & @@ -554,14 +558,15 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ var_lname = "Vertical remapping tracer concentration tendency for "//trim(Reg%Tr(m)%name) Tr%id_remap_conc= register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'_tendency_vert_remap', diag%axesTL, Time, var_lname, & - trim(units)//'s-1') + trim(units)//' s-1') var_lname = "Vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont = register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'h_tendency_vert_remap', & diag%axesTL, Time, var_lname, flux_units, v_extensive=.true., conversion = Tr%conv_scale) - var_lname = "Vertical sum of vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) + var_lname = "Vertical sum of vertical remapping tracer content tendency for "//& + trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont_2d = register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'h_tendency_vert_remap_2d', & diag%axesT1, Time, var_lname, flux_units, conversion = Tr%conv_scale) @@ -571,8 +576,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE, diag_ if (use_ALE .and. (Reg%ntr 0) unit2 = "("//trim(units)//")2" - Tr%id_tr_vardec = register_diag_field('ocean_model', trim(shortnm)//"_vardec", diag%axesTL, Time, & - "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1") + Tr%id_tr_vardec = register_diag_field('ocean_model', trim(shortnm)//"_vardec", diag%axesTL, & + Time, "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1") if (Tr%id_tr_vardec > 0) then ! Set up a new tracer for this tracer squared m2 = Reg%ntr+1 From 6e0726ab39dcab68e16d5fab44c4c566c229e3e0 Mon Sep 17 00:00:00 2001 From: Tom Robinson Date: Thu, 1 Feb 2018 09:35:09 -0500 Subject: [PATCH 169/170] Fixes multiline string in src/tracer/MOM_neutral_diffusion.F90 with incorrect usage of line continuation character. --- src/tracer/MOM_neutral_diffusion.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index f63e1cd6c2..cd4d456420 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1220,8 +1220,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, dRho = 0.5 * & ( ( dRdT_r(kl_right,ki_right) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,ki_right) - Tl(kl_left,ki_left) ) & + ( dRdS_r(kl_right,ki_right) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,ki_right) - Sl(kl_left,ki_left) ) ) - if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho," & - kl_left=",kl_left, " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right + if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & + "kl_left=",kl_left, " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right ! Which column has the lighter surface for the current indexes, kr and kl if (.not. reached_bottom) then if (dRho < 0.) then From 7eafe671e398f5245afa000c4c0d6d0551cd9905 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 5 Feb 2018 22:30:38 -0500 Subject: [PATCH 170/170] Fix NaN in radiation OBCs - NCI tests of circle_obcs with Intel debug executable failed with a floating invalid: https://accessdev.nci.org.au/jenkins/job/mom-ocean.org/job/MOM6_run/build=DEBUG,compiler=intel,experiment=ocean_only-circle_obcs,label=nah599,memory_type=dynamic_symmetric/lastBuild/console - Arrays u_old_rad_OBC abd v_old_rad_OBC were not set in parts of the halo which are referenced with in the open boundary code. This commit forces a copy of the entire data domain. --- src/core/MOM_dynamics_split_RK2.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index c9c148be9e..f24e8d068c 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -326,10 +326,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (associated(CS%OBC)) then if (CS%debug_OBC) call open_boundary_test_extern_h(G, CS%OBC, h) - do k=1,nz ; do j=js-1,je+1 ; do I=is-2,ie+1 + 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 - do k=1,nz ; do J=js-2,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do J=G%JsdB,G%JedB ; do i=G%isd,G%ied v_old_rad_OBC(i,J,k) = v_av(i,J,k) enddo ; enddo ; enddo endif