From e4b8767d9090f22ab7dd45f10f80423eda818f96 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 11 Jan 2018 10:35:51 -0500 Subject: [PATCH 001/259] optional ensemble_id to get_MOM_input --- src/framework/MOM_get_input.F90 | 28 +++++++++++++++++++++------- 1 file changed, 21 insertions(+), 7 deletions(-) diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index 2ee3e93bbd..359a306fba 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -30,7 +30,7 @@ module MOM_get_input !> Get the names of the I/O directories and initialization file. !! Also calls the subroutine that opens run-time parameter files. -subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) +subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, ensemble_num) type(param_file_type), optional, intent(out) :: param_file !< A structure to parse for run-time parameters. type(directories), optional, intent(out) :: dirs !< Container for paths and parameter file names. logical, optional, intent(in) :: check_params !< If present and False will stop error checking for @@ -38,8 +38,10 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) character(len=*), optional, intent(in) :: default_input_filename !< If present, is the value assumed for !! input_filename if input_filename is not listed !! in the namelist MOM_input_nml. + integer, intent(in), optional :: ensemble_num !< The ensemble id of the current member ! Local variables integer, parameter :: npf = 5 ! Maximum number of parameter files + character(len=240) :: & parameter_filename(npf), & ! List of files containing parameters. output_directory, & ! Directory to use to write the model output. @@ -77,10 +79,17 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) ! Store parameters in container if (present(dirs)) then - dirs%output_directory = slasher(ensembler(output_directory)) - dirs%restart_output_dir = slasher(ensembler(restart_output_dir)) - dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) - dirs%input_filename = ensembler(input_filename) + if (present(ensemble_num)) then + dirs%output_directory = slasher(ensembler(output_directory,ensemble_num)) + dirs%restart_output_dir = slasher(ensembler(restart_output_dir,ensemble_num)) + dirs%restart_input_dir = slasher(ensembler(restart_input_dir,ensemble_num)) + dirs%input_filename = ensembler(input_filename,ensemble_num) + else + dirs%output_directory = slasher(ensembler(output_directory)) + dirs%restart_output_dir = slasher(ensembler(restart_output_dir)) + dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) + dirs%input_filename = ensembler(input_filename) + endif endif ! Open run-time parameter file(s) @@ -89,8 +98,13 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) valid_param_files = 0 do io = 1, npf if (len_trim(trim(parameter_filename(io))) > 0) then - call open_param_file(ensembler(parameter_filename(io)), param_file, & - check_params, doc_file_dir=output_dir) + if (present(ensemble_num)) then + call open_param_file(ensembler(parameter_filename(io),ensemble_num), param_file, & + check_params, doc_file_dir=output_dir) + else + call open_param_file(ensembler(parameter_filename(io)), param_file, & + check_params, doc_file_dir=output_dir) + endif valid_param_files = valid_param_files + 1 endif enddo From 338f54b39c241fcaa62aeaf7d1ceb60839d13e53 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 3 Dec 2018 18:29:05 -0500 Subject: [PATCH 002/259] Begin work on linearized alpha, beta in neutral diffusion To avoid density inversions due to a nonlinear equation of state we choose to linearize alpha and beta by using layer averaged temperature and salinity in their calculation instead of values based on the polynomial reconstructions. This updates the initial calculations to alpha and beta at the interfaces and changes the d_delta_rho/dP equation. --- src/tracer/MOM_neutral_diffusion.F90 | 5 +++-- src/tracer/MOM_neutral_diffusion_aux.F90 | 15 +++++++++++---- 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b7d9dba592..e993b9c127 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -304,12 +304,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) - call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & + ! alpha, beta are calculated using T/S layer-averages as opposed to the polynomial + call calculate_density_derivs(T(:,j,k), S(:,j,k), 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 - call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & + call calculate_density_derivs(T(:,j,k), S(:,j,k), 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 diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index c25564b8da..8b06ffcabf 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -435,10 +435,17 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! By chain rule dT_dP= (dT_dz)*(dz/dP) = dT_dz / (Pbot-Ptop) 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 + + !! Total derivative of d_delta_rho wrt P + ! Note that this equation holds if alpha, beta are allowed to vary with T/S within the layer + ! However, we choose to linearize the EOS to ensure that density increases monotonically + ! 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 equation holds if T/S are taken to be layer averages so most of the d/dT d/dS terms are 0 + d_delta_rho_dP = 0.5*( delta_S*dbeta_dP + delta_T*dalpha_dP) + dS_dP*beta_avg + dT_dP*alpha_avg + ! This probably won't happen, but if it does take a bisection if (d_delta_rho_dP == 0.) then b = 0.5*(a+c) From ee782e16499f87028a536aa42508d21096eaa4a1 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 6 Dec 2018 12:22:47 -0500 Subject: [PATCH 003/259] Add position finder using linearized alpha, beta A simplified version of the neutral position finder is included which uses a linear interpolation of alpha and beta from the top interface to the bottom interface. Polynomial reconstructions are still used for T and S. Unit tests need to be written to ensure that this code works as expected. --- src/tracer/MOM_neutral_diffusion_aux.F90 | 90 ++++++++++++++++++++++++ 1 file changed, 90 insertions(+) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 8b06ffcabf..8d8f35aef5 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -334,6 +334,96 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' end function interpolate_for_nondim_position +!> Search a layer to find where delta_rho = 0 based on a linear interpolation of alpha and beta of the top and bottom +!! being searched and polynomial reconstructions of T and S. We need Newton's method because the T and S +!! reconstructions make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search +!! fall out of the interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta +!! means that second derivatives of the EOS are not needed. Note that delta in variable names below refers to +!! horizontal differences and 'd' refers to vertical differences +subroutine find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta_ref, alpha_top, beta_top, alpha_bot, & + beta_bot, ppoly_T, ppoly_S, z0, z ) + 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) :: alpha_top !< dRho/dT at top of layer being searched + real, intent(in) :: beta_top !< dRho/dS at top of layer being searched + real, intent(in) :: alpha_bot !< dRho/dT at bottom of layer being searched + real, intent(in) :: beta_bot !< dRho/dS at bottom of layer being 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) :: z0 !< Lower bound of position, also serves as the initial guess + real, intent(out) :: z !< Position where delta_rho = 0 + ! Local variables + real :: dalpha, dbeta, drho, drho_dz, alpha_z, beta_z, T_z, S_z, deltaT, deltaS, dT_dz, dS_dz, alpha_sum, beta_sum, dz + real :: drho_min, drho_max, ztest, zmin, zmax + real :: a1, a2 + integer :: iter + + ! Position independent quantities + dalpha = alpha_bot - alpha_top + dbeta = beta_bot - beta_top + ! Initial starting drho (used for bisection) + zmin = z0 ! Lower bounding interval + zmax = 1. ! Maximum bounding interval (bottom of layer) + T_z = evaluation_polynomial( ppoly_T, CS%nterm, zmin ) + S_z = evaluation_polynomial( ppoly_S, CS%nterm, zmin ) + drho_min = 0.5 * ( (alpha_top + alpha_ref )*(T_z - T_ref) + (beta_top + beta_ref)*(S_z - S_ref) ) + T_z = evaluation_polynomial( ppoly_T, CS%nterm, zmax ) + S_z = evaluation_polynomial( ppoly_S, CS%nterm, zmax ) + drho_max = 0.5 * ( (alpha_bot + alpha_ref )*(T_z - T_ref) + (beta_bot + beta_ref)*(S_z - S_ref) ) + + do iter = 1, CS%max_iter + ! Calculate quantities at the current nondimensional position + a1 = 1.-z + a2 = z + alpha_z = a1*alpha_top + a2*alpha_bot + beta_z = a1*beta_top + a2*beta_bot + T_z = evaluation_polynomial( ppoly_T, CS%nterm, z ) + S_z = evaluation_polynomial( ppoly_S, CS%nterm, z ) + deltaT = T_z - T_ref + deltaS = S_z - S_ref + alpha_sum = alpha_ref + alpha_z + beta_sum = beta_ref + beta_z + drho = 0.5 * ( alpha_sum*deltaT + beta_sum*deltaS ) + ! Check for convergence + if (ABS(drho) < CS%drho_tol) exit + ! Update bisection bracketing intervals + if (drho < 0. .and. drho > drho_min) then + drho_min = drho + zmin = z + elseif (drho > 0. .and. drho < drho_max) then + drho_max = drho + zmax = z + endif + + ! Calculate a Newton step + dT_dz = first_derivative_polynomial( ppoly_T, CS%nterm, z ) + dS_dz = first_derivative_polynomial( ppoly_S, CS%nterm, z ) + drho_dz = 0.5 * ( (dalpha*deltaT + alpha_sum*dT_dz) + (dbeta*deltaS + beta_sum*dS_dz) ) + ztest = z - drho/drho_dz + + ! Take a bisection if z falls out of [zmin,zmax] + if (ztest < zmin .or. ztest > zmax) then + if ( drho < 0. ) then + ztest = 0.5*(z + zmax) + else + ztest = 0.5*(zmin + z) + endif + endif + + ! Test to ensure we haven't stalled out + if ( abs(z-ztest) < CS%xtol ) exit + + ! Reset for next iteration + z = ztest + enddo + +end subroutine find_neutral_pos_linear_alpha_beta + !> 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, From bb56f400e709e5a378e886f4c23ef133fe4f9b79 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 6 Dec 2018 12:26:04 -0500 Subject: [PATCH 004/259] Revert "Begin work on linearized alpha, beta in neutral diffusion" This reverts commit 338f54b39c241fcaa62aeaf7d1ceb60839d13e53. --- src/tracer/MOM_neutral_diffusion.F90 | 5 ++--- src/tracer/MOM_neutral_diffusion_aux.F90 | 15 ++++----------- 2 files changed, 6 insertions(+), 14 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index e993b9c127..b7d9dba592 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -304,13 +304,12 @@ 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) - ! alpha, beta are calculated using T/S layer-averages as opposed to the polynomial - call calculate_density_derivs(T(:,j,k), S(:,j,k), ref_pres, & + 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 - call calculate_density_derivs(T(:,j,k), S(:,j,k), ref_pres, & + 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 diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 8d8f35aef5..9a881687b7 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -525,17 +525,10 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! By chain rule dT_dP= (dT_dz)*(dz/dP) = dT_dz / (Pbot-Ptop) 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 - ! Note that this equation holds if alpha, beta are allowed to vary with T/S within the layer - ! However, we choose to linearize the EOS to ensure that density increases monotonically - ! 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 equation holds if T/S are taken to be layer averages so most of the d/dT d/dS terms are 0 - d_delta_rho_dP = 0.5*( delta_S*dbeta_dP + delta_T*dalpha_dP) + dS_dP*beta_avg + dT_dP*alpha_avg - + ! 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 take a bisection if (d_delta_rho_dP == 0.) then b = 0.5*(a+c) From cb8d251838aabc4acb8ed72e155d7aaba2d9f70a Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 7 Dec 2018 12:03:20 -0500 Subject: [PATCH 005/259] Unit tests for new linearization of alpha and beta Some unit tests were added to linearize alpha and beta, however something is wrong in the routine. Need to be debugged --- src/tracer/MOM_neutral_diffusion.F90 | 23 +++++++++++++++++++++-- src/tracer/MOM_neutral_diffusion_aux.F90 | 16 ++++++++-------- 2 files changed, 29 insertions(+), 10 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b7d9dba592..0650c84997 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_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_neutral_diffusion_aux, only : check_neutral_positions, find_neutral_pos_linear_alpha_beta 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 @@ -1977,8 +1977,27 @@ logical function ndiff_unit_tests_discontinuous(verbose) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & "Temp/Salt stratified (Brent) ")) - deallocate(EOS) + ! Tests for linearized version of searching the layer for neutral surface position + ! EOS linear in T, uniform alpha + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.2, 0., -0.2, 0., -0.2, 0., & + (/12.,-4./), (/34.,0./), 0.), "Temp Uniform Linearized Alpha/Beta")) + ! EOS linear in S, uniform beta + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., 0., 0.8, 0., 0.8, 0., 0.8, & + (/12.,0./), (/36.,-2./), 0.), "Salt Uniform Linearized Alpha/Beta")) + ! EOS linear in T/S, uniform alpha/beta + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.2, 0.8, -0.2, 0.8, -0.2, 0.8, & + (/12.,-4./), (/34.,-2./), 0.), "Temp/salt Uniform Linearized Alpha/Beta")) + ! First EOS linear in T, insensitive to S +! ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.25, & +! find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.25, 0., -6., 0., -4., 0., & +! (/12.,-4./), (/34.,0./), 0.), "Temperature stratified Linearized Alpha/Beta")) + + deallocate(EOS) + deallocate(CS%ndiff_aux_CS) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' end function ndiff_unit_tests_discontinuous diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 9a881687b7..a8058e32f3 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -16,6 +16,7 @@ module MOM_neutral_diffusion_aux public drho_at_pos public search_other_column public interpolate_for_nondim_position +public find_neutral_pos_linear_alpha_beta public refine_nondim_position public check_neutral_positions public kahan_sum @@ -340,8 +341,8 @@ end function interpolate_for_nondim_position !! fall out of the interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta !! means that second derivatives of the EOS are not needed. Note that delta in variable names below refers to !! horizontal differences and 'd' refers to vertical differences -subroutine find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta_ref, alpha_top, beta_top, alpha_bot, & - beta_bot, ppoly_T, ppoly_S, z0, z ) +function find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta_ref, alpha_top, beta_top, & + alpha_bot, beta_bot, ppoly_T, ppoly_S, z0 ) result( z ) 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 @@ -356,7 +357,7 @@ subroutine find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the order N polynomial reconstruction of T within !! the layer to be searched. real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess - real, intent(out) :: z !< Position where delta_rho = 0 + real :: z !< Position where drho = 0 ! Local variables real :: dalpha, dbeta, drho, drho_dz, alpha_z, beta_z, T_z, S_z, deltaT, deltaS, dT_dz, dS_dz, alpha_sum, beta_sum, dz real :: drho_min, drho_max, ztest, zmin, zmax @@ -390,7 +391,7 @@ subroutine find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta beta_sum = beta_ref + beta_z drho = 0.5 * ( alpha_sum*deltaT + beta_sum*deltaS ) ! Check for convergence - if (ABS(drho) < CS%drho_tol) exit + if (ABS(drho) <= CS%drho_tol) exit ! Update bisection bracketing intervals if (drho < 0. .and. drho > drho_min) then drho_min = drho @@ -403,8 +404,7 @@ subroutine find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta ! Calculate a Newton step dT_dz = first_derivative_polynomial( ppoly_T, CS%nterm, z ) dS_dz = first_derivative_polynomial( ppoly_S, CS%nterm, z ) - drho_dz = 0.5 * ( (dalpha*deltaT + alpha_sum*dT_dz) + (dbeta*deltaS + beta_sum*dS_dz) ) - ztest = z - drho/drho_dz + drho_dz = 0.5*( (dalpha*deltaT + alpha_sum*dT_dz) + (dbeta*deltaS + beta_sum*dS_dz) ) ! Take a bisection if z falls out of [zmin,zmax] if (ztest < zmin .or. ztest > zmax) then @@ -416,13 +416,13 @@ subroutine find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta endif ! Test to ensure we haven't stalled out - if ( abs(z-ztest) < CS%xtol ) exit + if ( abs(z-ztest) <= CS%xtol ) exit ! Reset for next iteration z = ztest enddo -end subroutine find_neutral_pos_linear_alpha_beta +end function find_neutral_pos_linear_alpha_beta !> 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 From d1e51160c9cddeea885e9513f28a23253d5e3c86 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 7 Dec 2018 14:01:16 -0500 Subject: [PATCH 006/259] Restore lines and a unit test --- src/tracer/MOM_neutral_diffusion.F90 | 8 ++++---- src/tracer/MOM_neutral_diffusion_aux.F90 | 3 +++ 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 0650c84997..0af396d6b9 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1989,12 +1989,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/12.,0./), (/36.,-2./), 0.), "Salt Uniform Linearized Alpha/Beta")) ! EOS linear in T/S, uniform alpha/beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.2, 0.8, -0.2, 0.8, -0.2, 0.8, & + find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.5, 0.5, -0.5, 0.5, -0.5, 0.5, & (/12.,-4./), (/34.,-2./), 0.), "Temp/salt Uniform Linearized Alpha/Beta")) ! First EOS linear in T, insensitive to S -! ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.25, & -! find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.25, 0., -6., 0., -4., 0., & -! (/12.,-4./), (/34.,0./), 0.), "Temperature stratified Linearized Alpha/Beta")) + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.25, & + find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.25, 0., -6., 0., -4., 0., & + (/12.,-4./), (/34.,0./), 0.), "Temperature stratified Linearized Alpha/Beta")) deallocate(EOS) deallocate(CS%ndiff_aux_CS) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index a8058e32f3..35cb579681 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -377,6 +377,7 @@ function find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta_r S_z = evaluation_polynomial( ppoly_S, CS%nterm, zmax ) drho_max = 0.5 * ( (alpha_bot + alpha_ref )*(T_z - T_ref) + (beta_bot + beta_ref)*(S_z - S_ref) ) + z = z0 do iter = 1, CS%max_iter ! Calculate quantities at the current nondimensional position a1 = 1.-z @@ -406,6 +407,8 @@ function find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta_r dS_dz = first_derivative_polynomial( ppoly_S, CS%nterm, z ) drho_dz = 0.5*( (dalpha*deltaT + alpha_sum*dT_dz) + (dbeta*deltaS + beta_sum*dS_dz) ) + ztest = z - drho/drho_dz + ! Take a bisection if z falls out of [zmin,zmax] if (ztest < zmin .or. ztest > zmax) then if ( drho < 0. ) then From f61baa29e920808f0c3c06850d4c74b6923b851c Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 7 Dec 2018 14:10:09 -0500 Subject: [PATCH 007/259] Problem was in the unit test not the code, however still need to get more complicated unit tests working --- 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 0af396d6b9..e56cf3d270 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1986,11 +1986,11 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! EOS linear in S, uniform beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., 0., 0.8, 0., 0.8, 0., 0.8, & - (/12.,0./), (/36.,-2./), 0.), "Salt Uniform Linearized Alpha/Beta")) + (/12.,0./), (/34.,2./), 0.), "Salt Uniform Linearized Alpha/Beta")) ! EOS linear in T/S, uniform alpha/beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.5, 0.5, -0.5, 0.5, -0.5, 0.5, & - (/12.,-4./), (/34.,-2./), 0.), "Temp/salt Uniform Linearized Alpha/Beta")) + (/12.,-4./), (/34.,2./), 0.), "Temp/salt Uniform Linearized Alpha/Beta")) ! First EOS linear in T, insensitive to S ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.25, & find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.25, 0., -6., 0., -4., 0., & From 27fc954272483719124efe0395649d7590c53a67 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 11 Dec 2018 13:31:07 -0800 Subject: [PATCH 008/259] Add unit tests for linearized alpha,beta root finding --- src/tracer/MOM_neutral_diffusion.F90 | 14 +++++++++----- src/tracer/MOM_neutral_diffusion_aux.F90 | 1 + 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index e56cf3d270..c83c950f55 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1991,10 +1991,14 @@ logical function ndiff_unit_tests_discontinuous(verbose) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.5, 0.5, -0.5, 0.5, -0.5, 0.5, & (/12.,-4./), (/34.,2./), 0.), "Temp/salt Uniform Linearized Alpha/Beta")) - ! First EOS linear in T, insensitive to S - ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.25, & - find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.25, 0., -6., 0., -4., 0., & - (/12.,-4./), (/34.,0./), 0.), "Temperature stratified Linearized Alpha/Beta")) + ! EOS linear in T, insensitive to S + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.2, 0., -0.4, 0., -0.6, 0., & + (/12.,-4./), (/34.,0./), 0.), "Temp stratified Linearized Alpha/Beta")) + ! EOS linear in S, insensitive to T + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., 0., 0.8, 0., 1.0, 0., 0.5, & + (/12.,0./), (/34.,2./), 0.), "Salt stratified Linearized Alpha/Beta")) deallocate(EOS) deallocate(CS%ndiff_aux_CS) @@ -2246,7 +2250,7 @@ logical function test_rnp(expected_pos, test_pos, title) character(len=*), intent(in) :: title !< A label for this test ! Local variables integer :: stdunit = 6 ! Output to standard error - test_rnp = expected_pos /= test_pos + test_rnp = ABS(expected_pos - test_pos) > 2*EPSILON(test_pos) if (test_rnp) then write(stdunit,'(A, f20.16, " .neq. ", f20.16, " <-- WRONG")') title, expected_pos, test_pos else diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 35cb579681..fd3f9c9a41 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -408,6 +408,7 @@ function find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta_r drho_dz = 0.5*( (dalpha*deltaT + alpha_sum*dT_dz) + (dbeta*deltaS + beta_sum*dS_dz) ) ztest = z - drho/drho_dz + print *, ztest, z, drho, drho_dz ! Take a bisection if z falls out of [zmin,zmax] if (ztest < zmin .or. ztest > zmax) then From 262d84e7e965b2b2b041698aa4bd2b8032f533ef Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 13 Dec 2018 13:07:46 -0800 Subject: [PATCH 009/259] Incorporate option to find neutral position based on linearized alpha and beta --- src/tracer/MOM_neutral_diffusion.F90 | 49 ++++++++++++++++++++++++---- 1 file changed, 42 insertions(+), 7 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index c83c950f55..b5eb5b4628 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -43,6 +43,8 @@ module MOM_neutral_diffusion logical :: continuous_reconstruction = .true. !< True if using continuous PPM reconstruction at interfaces logical :: refine_position = .false. !< If true, iterate to refine the corresponding positions !! in neighboring columns + logical :: refine_lin = .true. !< If true, assume that alpha and beta linearly vary from the top + !! and bottom of a cell logical :: debug = .false. !< If true, write verbose debugging messages integer :: max_iter !< Maximum number of iterations if refine_position is defined real :: tolerance !< Convergence criterion representing difference from true neutrality @@ -181,6 +183,10 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) "The maximum number of iterations to be done before \n"// & "exiting the iterative loop to find the neutral surface", & default=10) + call get_param(param_file, mdl, "NDIFF_REFINE_LIN", CS%refine_lin, & + "Assume that alpha and beta vary linearly from the top\n"// & + "and bottom of the cell when iterating to find the \n"// & + "neutral position", default=.true.) call set_ndiff_aux_params(CS%ndiff_aux_CS, max_iter = max_iter, drho_tol = drho_tol, xtol = xtol) endif call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & @@ -1147,9 +1153,16 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol 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( 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 ) + if (CS%refine_lin) then + PoL(k_surface) = find_neutral_pos_linear_alpha_beta( CS%ndiff_aux_CS, & + T_other, S_other, dRdT_other, dRdS_other, & + dRdT_l(kl_left,1), dRdS_l(kl_left,1), dRdT_l(kl_left,2), dRdS_r(kl_left,2), & + ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), min_bound ) + else + 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 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. @@ -1200,9 +1213,16 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol 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(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 ) + if (CS%refine_lin) then + PoL(k_surface) = find_neutral_pos_linear_alpha_beta( CS%ndiff_aux_CS, & + T_other, S_other, dRdT_other, dRdS_other, & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), dRdT_r(kl_right,2), dRdS_r(kl_right,2), & + ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), min_bound ) + else + 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 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. @@ -1728,7 +1748,22 @@ logical function ndiff_unit_tests_continuous(verbose) (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pL (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pR (/0.,10.,0.,10.,0.,10.,0./), & ! hEff - 'Indentical columns with mixed layer') + 'Identical columns with mixed layer') + + ! Identical columns with thick mixed layer + call find_neutral_surface_positions_continuous(3, & + (/0.,10.,20.,30./), (/14.,14.,14.,14./), (/0.,0.,0.,0./), & ! Left positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Left dRdT and dRdS + (/0.,10.,20.,30./), (/14.,14.,14.,14./), (/0.,0.,0.,0./), & ! Right positions, T and S + (/-1.,-1.,-1.,-1./), (/1.,1.,1.,1./), &! Right dRdT and dRdS + PiLRo, PiRLo, KoL, KoR, hEff) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_nsp(v, 8, KoL, KoR, PiLRo, PiRLo, hEff, & + (/1,1,2,2,3,3,3,3/), & ! kL + (/1,1,2,2,3,3,3,3/), & ! kR + (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pL + (/0.,0.,0.,0.,0.,0.,1.,1./), & ! pR + (/0.,10.,0.,10.,0.,10.,0./), & ! hEff + 'Identical columns with thick mixed layer') ! Right column with unstable mixed layer call find_neutral_surface_positions_continuous(3, & From c42a432a79927aa5aa33e005202cf6ef8e9d723f Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 13 Dec 2018 16:39:41 -0800 Subject: [PATCH 010/259] Begin work to rewrite the discontinuous portion of the code to be compact --- src/tracer/MOM_neutral_diffusion.F90 | 785 +++++++++++++---------- src/tracer/MOM_neutral_diffusion_aux.F90 | 168 +---- 2 files changed, 445 insertions(+), 508 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b7d9dba592..f0270ac611 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -318,7 +318,7 @@ 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) ) + CS%stable_cell(i,j,:) ) enddo ; enddo endif @@ -342,7 +342,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, CS%ns(i,j)+CS%ns(i+1,j), & + call find_neutral_surface_positions_discontinuous(CS, G%ke, & 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,:,:), & @@ -363,7 +363,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, CS%ns(i,j)+CS%ns(i,j+1), & + call find_neutral_surface_positions_discontinuous(CS, G%ke, & 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,:,:), & @@ -1037,8 +1037,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol real :: lastP_left, lastP_right 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 + real :: pos top_connected_l(:) = .false. ; top_connected_r(:) = .false. bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. @@ -1050,24 +1049,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol call MOM_error(FATAL, "fine_neutral_surface_positions_discontinuous: refine_pos is requested, but " //& "polynomial 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 - ki_right = 1 ; lastK_right = 1 ; lastP_right = -1. - ki_left = 1 ; lastK_left = 1 ; lastP_left = -1. + ki_right = 1 + ki_left = 1 reached_bottom = .false. searching_left_column = .false. @@ -1075,146 +1060,126 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol ! Loop over each neutral surface, working from top to bottom 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 (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 - searching_left_column = .true. - searching_right_column = .false. - elseif (dRho > 0.) then - searching_right_column = .true. - searching_left_column = .false. - else ! dRho == 0. - if ( ( kl_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 - searching_left_column = .not. searching_left_column - searching_right_column = .not. searching_right_column - endif - endif - endif - if (searching_left_column) then - ! delta_rho is referenced to the right interface T, S, and P - if (CS%ref_pres>=0.) then - P_other = CS%ref_pres + ! If the layers are unstable, then simply point the surface to the previous location + if (.not. stable_left(kl_left)) then + PoL(ksurf) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoL(ksurf) = kl_left + if (ksurf > 1) then + PoR(ksurf) = PoR(ksurf-1) + KoR(ksurf) = KoR(ksurf-1) else - if (ki_right == 1) P_other = Pres_r(kl_right) - if (ki_right == 2) P_other = Pres_r(kl_right+1) + PoR(ksurf) = 0. + KoR(ksurf) = 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) - 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) + call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) + elseif (.not. stable_right(kl_right) then ! Check the right layer for stability + PoR(ksurf) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoR(ksurf) = kl_right + if (ksurf > 1) then + PoL(ksurf) = PoL(ksurf-1) + KoL(ksurf) = KoL(ksurf-1) 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) + PoL(ksurf) = 0. + KoL(ksurf) = 1 endif - ! 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 (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 - 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 - - ! Set the position within the starting column - PoR(k_surface) = REAL(ki_right-1) - KoR(k_surface) = kl_right - - ! 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) - - 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) + call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) + else ! Layers are stable so need to figure out whether we need to search right or left + drho = calc_delta_rho(CS, & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right) & + Tl(kl_left, ki_left) , Sl(kl_left, ki_left) , Pres_l(kl_left, ki_left) & + dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & + dRdT_l(kl_left, ki_left), dRdS_l(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 + ! Which column has the lighter surface for the current indexes, kr and kl + if (.not. reached_bottom) then + if (dRho < 0.) then + searching_left_column = .true. + searching_right_column = .false. + elseif (dRho > 0.) then + searching_left_column = .false. + searching_right_column = .true. + else ! dRho == 0. + if ( ( kl_left + kl_right == 2 ) .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 + searching_left_column = .not. searching_left_column + searching_right_column = .not. searching_right_column + endif endif - 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 (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) - 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) - - 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 - 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 (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 - 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 - ! Set the position within the starting column - PoL(k_surface) = REAL(ki_left-1) - KoL(k_surface) = kl_left - - ! Set position within the searched column - 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 ( 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) + + if (searching_left_column) then + ! Position of the right interface is known + PoR(k_surface) = ki_right - 1. + KoR(k_surface) = kl_right + + ! Calculate difference in density between left top interface and right interface + dRhoTop = calc_delta_rho(CS, & + Tl(kl_left, 1), Sl(kl_left, 1), Pres_l(kl_left, 1) & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right) & + dRdT_l(kl_left, 1), dRdS_l(kl_left, 1), & + dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) + ! Calculate difference in density between left bottom interface and right interface + dRhoBot = calc_delta_rho(CS, & + Tl(kl_left, 2), Sl(kl_left, 2), Pres_l(kl_left, 2) & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right) & + dRdT_l(kl_left, 2), dRdS_l(kl_left, 2), & + dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) + + ! search_other_column returns -1 if the surface connects somewhere between the layer + pos = search_other_column(dRhoTop, dRhoBot, ki_right, k_surface) + if (pos < 0.) pos = find_neutral_position( dRhoTop, dRhoBot, dRdT ) + PoL(k_surface) = pos + + 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 + 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) + write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) + endif + call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) + + elseif (searching_right_column) then + ! Position of the left interface is known + PoL(k_surface) = ki_left - 1. + KoL(k_surface) = kl_left + + ! Calculate difference in density between left top interface and right interface + dRhoTop = calc_delta_rho(CS, & + Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1) & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left) & + dRdT_r(kl_right, 1), dRdS_r(kl_right, ki_1) & + dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) + ! Calculate difference in density between left bottom interface and right interface + dRhoTop = calc_delta_rho(CS, & + Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2) & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left) & + dRdT_r(kl_right, 1), dRdS_r(kl_right, ki_1) & + dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) + ! search_other_column returns -1 if the surface connects somewhere between the layer + pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) + if (pos < 0.) then + pos = find_neutral_position( ) endif - 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 ) + PoR(k_surface) = pos + 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 + write(*,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) + write(*,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) + write(*,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) + endif + call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) + else + stop 'Else what?' 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, stable_l, reached_bottom, & - searching_left_column, searching_right_column) - - else - stop 'Else what?' endif - lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) - lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) - 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 @@ -1222,11 +1187,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol ! 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 + ! Check to see if neutral surfaces have crossed if hL or hR is negative if ( hL<0. .or. hR<0. ) then hEff(k_surface-1) = 0. - call MOM_error(WARNING, "hL or hR is negative") + call MOM_error(FATAL, "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)) @@ -1260,6 +1224,123 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol end subroutine find_neutral_surface_positions_discontinuous +!> Sweep down through the column and mark as stable if the bottom interface of a cell is denser than the top +subroutine mark_unstable_cells(nk, dRdT, dRdS, T, S, P, stable_cell) + integer, intent(in) :: nk !< Number of levels in a column + 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 !< Temperature at interfaces + real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces + real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces + logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified + + integer :: k, first_stable, prev_stable + real :: delta_rho + + do k = 1,nk + stable_cell(k) = ( calc_delta_rho(CS, T(k,2), S(k,2), P(k,2), T(k,1), S(k,1), P(k,1), & + dRdT(k,2), dRdS(k,2), dRdT(k,1), dRdS(k,2)) >= 0. ) + enddo +end subroutine mark_unstable_cells + +!> Searches the "other" (searched) column for the position of the neutral surface +real function search_other_column(dRhoTop, dRhoBot, ki_other, ksurf ) result(pos) + real, intent(in ) :: dRhoTop !< Density difference across top interface + real, intent(in ) :: dRhoBot !< Density difference across top interface + integer, intent(in ) :: ki_other !< Index of interface being searched from + integer, intent(in ) :: ksurf !< Current index of neutral surface + + if ( (drhotop > 0.) .or. (ksurf == 1) ) then ! First interface or lighter than anything in layer + pos = 0. + elseif ( drhotop > drhobot ) ! Unstably stratified + pos = 1. + elseif ( drhotop < 0. .and. drhobot < 0.) ! Denser than anything in layer + pos = 1. + elseif ( drhotop == 0. .and. drhobot == 0. ) ! Perfectly unstratified + pos = ki_other - 1 + else + pos = -1 + endif + +end function search_other_column + +!> Use some form of interpolation or rootfinding to find the position of a neutral surface within the layer +!! In order of increasing accuracy +!! 1. Delta_rho varies linearly, find 0 crossing +!! 2. Alpha and beta vary linearly from top to bottom, rootfinding for 0. position +!! 3. Keep recalculating alpha and beta (no pressure dependence), rootfinding for 0. position +!! 4. Full nonlinear equation of state +real function find_neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & + Tpoly, Spoly, P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot) + type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure + real, optional :: dRhoTop !< delta rho at top interface + real, optional :: dRhoBot !< delta rho at bottom interface + real, optional :: T_ref !< Temperature of other interface + real, optional :: S_ref !< Salinity of other interface + real, optional :: P_ref !< Pressure of other interface + real, optional :: dRdT_ref !< drho/dT of other interface + real, optional :: dRdS_ref !< drho/dS of other interface + real, optional, dimension(CS%nterm) :: Tpoly !< Temperature polynomial reconstruction + real, optional, dimension(CS%nterm) :: Spoly !< Temperature polynomial reconstruction + real, optional :: P_top !< Pressure at top interface + real, optional :: P_bot !< Pressure at bottom interface + real, optional :: dRdT_top !< drho/dT at cell's top interface + real, optional :: dRdS_top !< drho/dS at cell's top interface + real, optional :: dRdT_bot !< drho/dT at cell's bottom interface + real, optional :: dRdS_bot !< drho/dS at cell's bottom interface + + if (CS%neutral_pos_method == 1) then + PoL(k_surface) = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) + elseif (CS%neutral_pos_method == 2) then + call MOM_error(FATAL,"neutral_pos_method 2 has yet to be implemented") + elseif (CS%neutral_pos_method == 3) then + + + + + +end function find_neutral_pos + +!> Calculate the difference in density between two points in a variety of ways +real function calc_delta_rho(CS, T1, S1, p1_in, T2, S2, p2_in, drdt1, drds1, drdt2, drds2 ) result(delta_rho) + type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure + real, intent(in) :: T1 !< Temperature at point 1 + real, intent(in) :: S1 !< Salinity at point 1 + real, intent(in) :: p1_in !< Pressure at point 1 + real, intent(in) :: T2 !< Temperature at point 2 + real, intent(in) :: S2 !< Salinity at point 2 + real, intent(in) :: p2_in !< Pressure at point 2 + real, optional, intent(in) :: drdt1 !< drho_dt at point 1 + real, optional, intent(in) :: drds1 !< drho_ds at point 1 + real, optional, intent(in) :: drdt2 !< drho_dt at point 2 + real, optional, intent(in) :: drds2 !< drho_ds at point 2 + real :: delta_rho, rho1, rho2, p1, p2 + + ! Use the same reference pressure or the in-situ pressure + if (CS%ref_pres > 0.) then + p1 = CS%ref_pres + p2 = CS%ref_pres + else + p1 = p1_in + p2 = p2_in + endif + + ! Use the full linear equation of state to calculate the difference in density (expensive!) + if (CS%delta_rho_form == 'full') then + call calculate_density( T1, S1, p1, rho1, CS%EOS ) + call calculate_density( T2, S2, p2, rho2, CS%EOS ) + delta_rho = rho1 - rho2 + ! Use a linearized version of the equation of state + elseif (CS%delta_rho_form == 'linear') + if (.not. (PRESENT(drdt1) .and. PRESENT(drds1) .and. present(drdt2) .and. present(drds2)) ) then + call MOM_error(FATAL,"DELTA_RHO_FORM == linear requires drdt and drds") + else + delta_rho = 0.5 *( (drdt1+drdt2)*(T1-T2) + (drds1+drds2)*(S1-S2) ) + endif + endif + +end function calc_delta_rho + !> 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 @@ -1781,205 +1862,205 @@ end function ndiff_unit_tests_continuous logical function ndiff_unit_tests_discontinuous(verbose) logical, intent(in) :: verbose !< It true, write results to stdout - ! Local variables - integer, parameter :: nk = 3 - integer, parameter :: ns = nk*4 - real, dimension(nk) :: Sl, Sr, Tl, Tr, hl, hr - real, dimension(nk,2) :: TiL, SiL, TiR, SiR - real, dimension(nk+1) :: Pres_l, Pres_R - integer, dimension(ns) :: KoL, KoR - real, dimension(ns) :: PoL, PoR - real, dimension(ns-1) :: hEff, Flx - type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure - 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 - real, dimension(nk,2) :: dRdT, dRdS - logical, dimension(nk) :: stable_l, stable_r - integer :: iMethod - integer :: ns_l, ns_r - real :: h_neglect, h_neglect_edge - integer :: k - logical :: v - - v = verbose +! ! Local variables +! integer, parameter :: nk = 3 +! integer, parameter :: ns = nk*4 +! real, dimension(nk) :: Sl, Sr, Tl, Tr, hl, hr +! real, dimension(nk,2) :: TiL, SiL, TiR, SiR +! real, dimension(nk+1) :: Pres_l, Pres_R +! integer, dimension(ns) :: KoL, KoR +! real, dimension(ns) :: PoL, PoR +! real, dimension(ns-1) :: hEff, Flx +! type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure +! 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 +! real, dimension(nk,2) :: dRdT, dRdS +! logical, dimension(nk) :: stable_l, stable_r +! integer :: iMethod +! integer :: ns_l, ns_r +! real :: h_neglect, h_neglect_edge +! integer :: k +! logical :: v +! +! v = 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. - 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. ) - - hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) ; Pres_l(1) = 0. ; Pres_r(1) = 0. - 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, 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 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(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 - (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR - (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pL - (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pR - (/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, 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 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(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 - (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoR - (/0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0/), & ! pL - (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pR - (/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, 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 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(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 - (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoR - (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pL - (/0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0/), & ! pR - (/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, 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 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(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 - (/1,1,1,1,1,1,1,2,2,2,3,3/), & ! KoR - (/0.0, 1.0, 0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.0, 1.0/), & ! pL - (/0.0, 0.0, 0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0, 0.0, 1.0/), & ! pR - (/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, 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 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(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 - (/1,1,1,1,1,1,1,1,2,2,3,3/), & ! KoR - (/0.0, 1.0, 0.0, 1.0, 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0/), & ! pL - (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0/), & ! pR - (/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, 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 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(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 - (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR - (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pL - (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pR - (/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, 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 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(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 - (/1,1,1,1,1,1,2,2,2,3,3,3/), & ! KoR - (/0.0, 1.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.5, 1.0, 1.0/), & ! pL - (/0.0, 0.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 0.0, 0.5, 1.0/), & ! pR - (/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, 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 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(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 - (/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, 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') - - 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, 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(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 - (/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) - - 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( & - 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( & - 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( & - 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( & - 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( & - 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( & - CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & - "Temp/Salt stratified (Brent) ")) - deallocate(EOS) - - if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' +! 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. +! 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. ) +! +! hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) ; Pres_l(1) = 0. ; Pres_r(1) = 0. +! 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, 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 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(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 +! (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR +! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pL +! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pR +! (/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, 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 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(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 +! (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoR +! (/0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0/), & ! pL +! (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pR +! (/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, 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 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(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 +! (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoR +! (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pL +! (/0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0/), & ! pR +! (/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, 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 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(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 +! (/1,1,1,1,1,1,1,2,2,2,3,3/), & ! KoR +! (/0.0, 1.0, 0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.0, 1.0/), & ! pL +! (/0.0, 0.0, 0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0, 0.0, 1.0/), & ! pR +! (/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, 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 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(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 +! (/1,1,1,1,1,1,1,1,2,2,3,3/), & ! KoR +! (/0.0, 1.0, 0.0, 1.0, 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0/), & ! pL +! (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0/), & ! pR +! (/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, 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 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(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 +! (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR +! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pL +! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pR +! (/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, 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 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(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 +! (/1,1,1,1,1,1,2,2,2,3,3,3/), & ! KoR +! (/0.0, 1.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.5, 1.0, 1.0/), & ! pL +! (/0.0, 0.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 0.0, 0.5, 1.0/), & ! pR +! (/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, 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 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(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 +! (/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, 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') +! +! 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, 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(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 +! (/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) +! +! 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( & +! 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( & +! 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( & +! 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( & +! 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( & +! 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( & +! CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & +! "Temp/Salt stratified (Brent) ")) +! deallocate(EOS) +! +! if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' end function ndiff_unit_tests_discontinuous diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index c25564b8da..2e7cbb6aaf 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -58,89 +58,28 @@ subroutine set_ndiff_aux_params( CS, deg, max_iter, drho_tol, xtol, ref_pres, fo 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) - integer, intent(in) :: nk !< Number of levels in a column - 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 - - ! 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 - - 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 - first_stable = k - exit - 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 - - ! 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 - !> 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) +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, 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 = .false. + if (ki == 2) then ! At the bottom interface + if ((ki == 2) .and. (kl < nk) ) then ! Not at the bottom so just go to the next layer + kl = kl+1 + ki = 1 + elseif ((kl == nk) .and. (ki==2)) then 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. + searching_this_column = .false. + searching_other_column = .true. + endif + elseif (ki==1) ! At the top interface + ki = 2 ! Next interface is same layer, but bottom interface else call MOM_error(FATAL,"Unanticipated eventuality in increment_interface") endif @@ -214,89 +153,6 @@ subroutine drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppol 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 - 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) - 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 - 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) - 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. From d71991ed946b8cd2c8d8807fd0e30c7f3bea0a44 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 14 Dec 2018 10:41:00 -0800 Subject: [PATCH 011/259] Fix typos preventing compile --- src/tracer/MOM_neutral_diffusion.F90 | 376 +++++++++++++---------- src/tracer/MOM_neutral_diffusion_aux.F90 | 30 -- 2 files changed, 222 insertions(+), 184 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index f0270ac611..688a0bba16 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -8,15 +8,15 @@ module MOM_neutral_diffusion 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 : calculate_density, 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 : 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 : calc_drho, drho_at_pos +use MOM_neutral_diffusion_aux, only : 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 @@ -41,8 +41,6 @@ module MOM_neutral_diffusion integer :: nsurf !< Number of neutral surfaces 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. !< If true, iterate to refine the corresponding positions - !! in neighboring columns logical :: debug = .false. !< If true, write verbose debugging messages integer :: max_iter !< Maximum number of iterations if refine_position is defined real :: tolerance !< Convergence criterion representing difference from true neutrality @@ -75,12 +73,16 @@ module MOM_neutral_diffusion ! Variables needed for discontinuous reconstructions real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature (degC) real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity (ppt) + real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressure (Pa) 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 => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. + integer :: neutral_pos_method !< Method to find the position of a neutral surface within the layer + character(len=40) :: delta_rho_form + integer :: id_uhEff_2d = -1 !< Diagnostic IDs integer :: id_vhEff_2d = -1 !< Diagnostic IDs @@ -150,10 +152,8 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) ! Initialize and configure remapping if (CS%continuous_reconstruction .eqv. .false.) then 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"// & - "polynomial reconstructions of T/S.", & + "Extrapolate at the top and bottommost cells, otherwise \n"// & + "assume boundaries are piecewise constant", & default=.false.) call get_param(param_file, mdl, "NDIFF_REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used\n"//& @@ -162,13 +162,30 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) - 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"// & - "nonlinearity of the equation of state and the\n"// & - "polynomial reconstructions of T/S.", & + call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & + "Extrapolate at the top and bottommost cells, otherwise \n"// & + "assume boundaries are piecewise constant", & default=.false.) - if (CS%refine_position) then + call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & + "Method used to find the neutral position \n"// & + "1. Delta_rho varies linearly, find 0 crossing \n"// & + "2. Alpha and beta vary linearly from top to bottom, \n"// & + " Newton's method for neutral position \n"// & + "3. Keep recalculating alpha and beta (no pressure \n"// & + " dependence) Newton's method for neutral position \n"// & + "4. Full nonlinear equation of state, Brent's method \n"// & + " for neutral position", default=1) + if (CS%neutral_pos_method > 4 .or. CS%neutral_pos_method < 0) then + call MOM_error(FATAL,"Invalid option for NEUTRAL_POS_METHOD") + endif + + call get_param(param_file, mdl, "DELTA_RHO_FORM", CS%delta_rho_form, & + "Determine how the difference in density is calculated \n"// & + " full : Difference of in-situ densities \n"// & + " no_pressure: Calculated from dRdT, dRdS, but no \n"// & + " pressure dependence", & + default="no_pressure") + if (CS%neutral_pos_method > 1) then 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.", & @@ -202,6 +219,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) CS%nsurf = 4*G%ke ! Discontinuous means that every interface has four connections allocate(CS%T_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%T_i(:,:,:,:) = 0. allocate(CS%S_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%S_i(:,:,:,:) = 0. + allocate(CS%P_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%P_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%deg+1)) ; CS%ppoly_coeffs_T(:,:,:,:) = 0. @@ -280,6 +298,19 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*GV%H_to_Pa enddo ; enddo ; enddo + ! Pressures at the interfaces, this is redundant as P_i(k,1) = P_i(k-1,2) however retain tis + ! for now ensure consitency of indexing for diiscontinuous reconstructions + if (.not. CS%continuous_reconstruction) then + do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%P_i(i,j,1,1) = 0. + CS%P_i(i,j,1,2) = h(i,j,1)*GV%H_to_Pa + enddo ; enddo + do k=2,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%P_i(i,j,k,1) = CS%P_i(i,j,k-1,2) + CS%P_i(i,j,k,2) = CS%P_i(i,j,k-1,2) + h(i,j,k)*GV%H_to_Pa + enddo ; enddo ; enddo + endif + do j = G%jsc-1, G%jec+1 ! Interpolate state to interface do i = G%isc-1, G%iec+1 @@ -317,8 +348,8 @@ 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,:) ) + call mark_unstable_cells( CS, G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) enddo ; enddo endif @@ -343,9 +374,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, & - CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%P_i(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%P_i(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,:,:), & @@ -364,9 +395,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, & - CS%Pint(i,j,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%P_i(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%P_i(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,:,:), & @@ -987,20 +1018,19 @@ 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(CS, nk, ns, Pres_l, hcol_l, Tl, Sl, & +subroutine find_neutral_surface_positions_discontinuous(CS, nk, 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), intent(inout) :: CS !< Neutral diffusion control structure + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels - integer, intent(in) :: ns !< Number of neutral surfaces - real, dimension(nk+1), intent(in) :: Pres_l !< Left-column interface pressure (Pa) + real, dimension(nk,2), 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,2), 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) @@ -1024,6 +1054,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction ! 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 @@ -1039,18 +1070,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol real :: T_other, S_other, P_other, dRdT_other, dRdS_other real :: pos - top_connected_l(:) = .false. ; top_connected_r(:) = .false. - bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. - - ! 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 - ! Initialize variables for the search + ns = 4*nk ki_right = 1 ki_left = 1 @@ -1062,33 +1083,33 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol neutral_surfaces: do k_surface = 1, ns ! If the layers are unstable, then simply point the surface to the previous location - if (.not. stable_left(kl_left)) then - PoL(ksurf) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 - KoL(ksurf) = kl_left - if (ksurf > 1) then - PoR(ksurf) = PoR(ksurf-1) - KoR(ksurf) = KoR(ksurf-1) + if (.not. stable_l(kl_left)) then + PoL(k_surface) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoL(k_surface) = kl_left + if (k_surface > 1) then + PoR(k_surface) = PoR(k_surface-1) + KoR(k_surface) = KoR(k_surface-1) else - PoR(ksurf) = 0. - KoR(ksurf) = 1 + PoR(k_surface) = 0. + KoR(k_surface) = 1 endif call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) - elseif (.not. stable_right(kl_right) then ! Check the right layer for stability - PoR(ksurf) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 - KoR(ksurf) = kl_right - if (ksurf > 1) then - PoL(ksurf) = PoL(ksurf-1) - KoL(ksurf) = KoL(ksurf-1) + elseif (.not. stable_r(kl_right)) then ! Check the right layer for stability + PoR(k_surface) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoR(k_surface) = kl_right + if (k_surface > 1) then + PoL(k_surface) = PoL(k_surface-1) + KoL(k_surface) = KoL(k_surface-1) else - PoL(ksurf) = 0. - KoL(ksurf) = 1 + PoL(k_surface) = 0. + KoL(k_surface) = 1 endif call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) else ! Layers are stable so need to figure out whether we need to search right or left - drho = calc_delta_rho(CS, & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right) & - Tl(kl_left, ki_left) , Sl(kl_left, ki_left) , Pres_l(kl_left, ki_left) & - dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & + drho = calc_delta_rho(CS, & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & + Tl(kl_left, ki_left) , Sl(kl_left, ki_left) , Pres_l(kl_left, ki_left), & + dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & dRdT_l(kl_left, ki_left), dRdS_l(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 @@ -1117,21 +1138,27 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol KoR(k_surface) = kl_right ! Calculate difference in density between left top interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tl(kl_left, 1), Sl(kl_left, 1), Pres_l(kl_left, 1) & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right) & - dRdT_l(kl_left, 1), dRdS_l(kl_left, 1), & + dRhoTop = calc_delta_rho(CS, & + Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & + dRdT_l(kl_left,1), dRdS_l(kl_left,1), & dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) ! Calculate difference in density between left bottom interface and right interface dRhoBot = calc_delta_rho(CS, & - Tl(kl_left, 2), Sl(kl_left, 2), Pres_l(kl_left, 2) & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right) & - dRdT_l(kl_left, 2), dRdS_l(kl_left, 2), & + Tl(kl_left,2), Sl(kl_left,2), Pres_l(kl_left,2), & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & + dRdT_l(kl_left,2), dRdS_l(kl_left,2), & dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_right, k_surface) - if (pos < 0.) pos = find_neutral_position( dRhoTop, dRhoBot, dRdT ) + if (pos < 0.) pos = neutral_pos(CS, dRhoTop, dRhoBot, & + Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& + dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & + ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), & + Pres_l(kl_left,1), Pres_l(kl_left,2), & + dRdT_l(kl_left,1), dRdS_l(kl_left,1), & + dRdT_l(kl_left,2), dRdS_l(kl_left,2) ) PoL(k_surface) = pos if (CS%debug) then @@ -1151,21 +1178,25 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol ! Calculate difference in density between left top interface and right interface dRhoTop = calc_delta_rho(CS, & - Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1) & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left) & - dRdT_r(kl_right, 1), dRdS_r(kl_right, ki_1) & + Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), & dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) ! Calculate difference in density between left bottom interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2) & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left) & - dRdT_r(kl_right, 1), dRdS_r(kl_right, ki_1) & + dRhoTop = calc_delta_rho(CS, & + Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & + dRdT_r(kl_right,2), dRdS_r(kl_right,2) , & dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) - if (pos < 0.) then - pos = find_neutral_position( ) - endif + if (pos < 0.) pos = neutral_pos(CS, dRhoTop, dRhoBot, & + Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & + dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & + ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), & + Pres_r(kl_right,1), Pres_r(kl_right,2), & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), & + dRdT_r(kl_right,2), dRdS_r(kl_right,2) ) PoR(k_surface) = pos if (CS%debug) then write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching right layer ", kl_right, & @@ -1200,32 +1231,33 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol endif endif enddo neutral_surfaces - if (CS%debug) then - 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 - write(*,'(A,E16.6)') "Total thickness of sublayers: ", SUM(hEff) - write(*,*) "==========End Neutral Surfaces==========" - endif +! if (CS%debug) then +! 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 +! write(*,'(A,E16.6)') "Total thickness of sublayers: ", SUM(hEff) +! write(*,*) "==========End Neutral Surfaces==========" +! endif end subroutine find_neutral_surface_positions_discontinuous !> Sweep down through the column and mark as stable if the bottom interface of a cell is denser than the top -subroutine mark_unstable_cells(nk, dRdT, dRdS, T, S, P, stable_cell) +subroutine mark_unstable_cells(CS, nk, dRdT, dRdS, T, S, P, stable_cell) + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels in a column 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 @@ -1239,7 +1271,7 @@ subroutine mark_unstable_cells(nk, dRdT, dRdS, T, S, P, stable_cell) do k = 1,nk stable_cell(k) = ( calc_delta_rho(CS, T(k,2), S(k,2), P(k,2), T(k,1), S(k,1), P(k,1), & - dRdT(k,2), dRdS(k,2), dRdT(k,1), dRdS(k,2)) >= 0. ) + dRdT(k,2), dRdS(k,2), dRdT(k,1), dRdS(k,2)) > 0. ) enddo end subroutine mark_unstable_cells @@ -1252,11 +1284,11 @@ real function search_other_column(dRhoTop, dRhoBot, ki_other, ksurf ) result(pos if ( (drhotop > 0.) .or. (ksurf == 1) ) then ! First interface or lighter than anything in layer pos = 0. - elseif ( drhotop > drhobot ) ! Unstably stratified + elseif ( drhotop > drhobot ) then ! Unstably stratified pos = 1. - elseif ( drhotop < 0. .and. drhobot < 0.) ! Denser than anything in layer + elseif ( drhotop < 0. .and. drhobot < 0.) then ! Denser than anything in layer pos = 1. - elseif ( drhotop == 0. .and. drhobot == 0. ) ! Perfectly unstratified + elseif ( drhotop == 0. .and. drhobot == 0. ) then ! Perfectly unstratified pos = ki_other - 1 else pos = -1 @@ -1264,14 +1296,42 @@ real function search_other_column(dRhoTop, dRhoBot, ki_other, ksurf ) result(pos end function search_other_column +!> 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 + integer :: k + + reached_bottom = .false. + if (ki == 2) then ! At the bottom interface + if ((ki == 2) .and. (kl < nk) ) then ! Not at the bottom so just go to the next layer + kl = kl+1 + ki = 1 + elseif ((kl == nk) .and. (ki==2)) then + reached_bottom = .true. + searching_this_column = .false. + searching_other_column = .true. + endif + elseif (ki==1) then ! At the top interface + ki = 2 ! Next interface is same layer, but bottom interface + else + call MOM_error(FATAL,"Unanticipated eventuality in increment_interface") + endif +end subroutine increment_interface + !> Use some form of interpolation or rootfinding to find the position of a neutral surface within the layer !! In order of increasing accuracy !! 1. Delta_rho varies linearly, find 0 crossing !! 2. Alpha and beta vary linearly from top to bottom, rootfinding for 0. position !! 3. Keep recalculating alpha and beta (no pressure dependence), rootfinding for 0. position !! 4. Full nonlinear equation of state -real function find_neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & - Tpoly, Spoly, P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot) +real function neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & + Tpoly, Spoly, P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot) & + result(pos) type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure real, optional :: dRhoTop !< delta rho at top interface real, optional :: dRhoBot !< delta rho at bottom interface @@ -1280,8 +1340,8 @@ real function find_neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_r real, optional :: P_ref !< Pressure of other interface real, optional :: dRdT_ref !< drho/dT of other interface real, optional :: dRdS_ref !< drho/dS of other interface - real, optional, dimension(CS%nterm) :: Tpoly !< Temperature polynomial reconstruction - real, optional, dimension(CS%nterm) :: Spoly !< Temperature polynomial reconstruction + real, optional, dimension(CS%deg+1) :: Tpoly !< Temperature polynomial reconstruction + real, optional, dimension(CS%deg+1) :: Spoly !< Temperature polynomial reconstruction real, optional :: P_top !< Pressure at top interface real, optional :: P_bot !< Pressure at bottom interface real, optional :: dRdT_top !< drho/dT at cell's top interface @@ -1290,16 +1350,16 @@ real function find_neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_r real, optional :: dRdS_bot !< drho/dS at cell's bottom interface if (CS%neutral_pos_method == 1) then - PoL(k_surface) = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) + pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) elseif (CS%neutral_pos_method == 2) then - call MOM_error(FATAL,"neutral_pos_method 2 has yet to be implemented") + call MOM_error(FATAL,"neutral_pos_method 2 has yet to be implemented") elseif (CS%neutral_pos_method == 3) then - - - - - -end function find_neutral_pos +! pos = refine_nondim_position(CS, T_ref, S_ref, dRdT_ref, dRdS_ref, P_top, P_bot, & +! Tpoly, Spoly, dRhoTop, dRhoBot, 0.) + else + call MOM_error(FATAL, "Invalid choice for neutral_pos_method") + endif +end function neutral_pos !> Calculate the difference in density between two points in a variety of ways real function calc_delta_rho(CS, T1, S1, p1_in, T2, S2, p2_in, drdt1, drds1, drdt2, drds2 ) result(delta_rho) @@ -1314,7 +1374,7 @@ real function calc_delta_rho(CS, T1, S1, p1_in, T2, S2, p2_in, drdt1, drds1, drd real, optional, intent(in) :: drds1 !< drho_ds at point 1 real, optional, intent(in) :: drdt2 !< drho_dt at point 2 real, optional, intent(in) :: drds2 !< drho_ds at point 2 - real :: delta_rho, rho1, rho2, p1, p2 + real :: rho1, rho2, p1, p2, pmid ! Use the same reference pressure or the in-situ pressure if (CS%ref_pres > 0.) then @@ -1327,11 +1387,11 @@ real function calc_delta_rho(CS, T1, S1, p1_in, T2, S2, p2_in, drdt1, drds1, drd ! Use the full linear equation of state to calculate the difference in density (expensive!) if (CS%delta_rho_form == 'full') then - call calculate_density( T1, S1, p1, rho1, CS%EOS ) + call calculate_density( T1, S1, p1, rho1, CS%EOS ) call calculate_density( T2, S2, p2, rho2, CS%EOS ) delta_rho = rho1 - rho2 ! Use a linearized version of the equation of state - elseif (CS%delta_rho_form == 'linear') + elseif (CS%delta_rho_form == 'no_pressure') then if (.not. (PRESENT(drdt1) .and. PRESENT(drds1) .and. present(drdt2) .and. present(drds2)) ) then call MOM_error(FATAL,"DELTA_RHO_FORM == linear requires drdt and drds") else @@ -1862,46 +1922,54 @@ end function ndiff_unit_tests_continuous logical function ndiff_unit_tests_discontinuous(verbose) logical, intent(in) :: verbose !< It true, write results to stdout -! ! Local variables -! integer, parameter :: nk = 3 -! integer, parameter :: ns = nk*4 -! real, dimension(nk) :: Sl, Sr, Tl, Tr, hl, hr -! real, dimension(nk,2) :: TiL, SiL, TiR, SiR -! real, dimension(nk+1) :: Pres_l, Pres_R -! integer, dimension(ns) :: KoL, KoR -! real, dimension(ns) :: PoL, PoR -! real, dimension(ns-1) :: hEff, Flx -! type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure -! 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 -! real, dimension(nk,2) :: dRdT, dRdS -! logical, dimension(nk) :: stable_l, stable_r -! integer :: iMethod -! integer :: ns_l, ns_r -! real :: h_neglect, h_neglect_edge -! integer :: k -! logical :: v -! -! v = verbose + ! Local variables + integer, parameter :: nk = 3 + integer, parameter :: ns = nk*4 + real, dimension(nk) :: Sl, Sr, Tl, Tr, hl, hr + real, dimension(nk,2) :: TiL, SiL, TiR, SiR + real, dimension(nk,2) :: Pres_l, Pres_r + integer, dimension(ns) :: KoL, KoR + real, dimension(ns) :: PoL, PoR + real, dimension(ns-1) :: hEff, Flx + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + 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 + real, dimension(nk,2) :: dRdT, dRdS + logical, dimension(nk) :: stable_l, stable_r + integer :: iMethod + integer :: ns_l, ns_r + real :: h_neglect, h_neglect_edge + integer :: k + logical :: v + + v = 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 + write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' ! -! ! 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. -! 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. ) -! -! hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) ; Pres_l(1) = 0. ; Pres_r(1) = 0. -! do k = 1,nk ; Pres_l(k+1) = Pres_l(k) + hL(k) ; Pres_r(k+1) = Pres_r(k) + hR(k) ; enddo + 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. + 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. ) + + hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) ; Pres_l(1) = 0. ; Pres_r(1) = 0. + Pres_l(1,1) = 0. ; Pres_l(1,2) = hL(1) ; Pres_r(1,1) = 0. ; Pres_r(1,2) = hR(1) + do k = 2,nk + Pres_l(k,1) = Pres_l(k-1,2) + Pres_l(k,2) = Pres_l(k,1) + hL(k) + Pres_r(k,1) = Pres_r(k-1,2) + Pres_r(k,2) = Pres_r(k-1,) + 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, h_neglect, h_neglect_edge ) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 2e7cbb6aaf..dc65779ff0 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -10,11 +10,8 @@ module MOM_neutral_diffusion_aux implicit none ; private public set_ndiff_aux_params -public mark_unstable_cells -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 @@ -58,33 +55,6 @@ subroutine set_ndiff_aux_params( CS, deg, max_iter, drho_tol, xtol, ref_pres, fo end subroutine set_ndiff_aux_params -!> 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 - integer :: k - - reached_bottom = .false. - if (ki == 2) then ! At the bottom interface - if ((ki == 2) .and. (kl < nk) ) then ! Not at the bottom so just go to the next layer - kl = kl+1 - ki = 1 - elseif ((kl == nk) .and. (ki==2)) then - reached_bottom = .true. - searching_this_column = .false. - searching_other_column = .true. - endif - elseif (ki==1) ! At the top interface - ki = 2 ! Next interface is same layer, but bottom interface - 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 From d973b4e1daa1897f7f27b528555f690184f936aa Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 2 Jan 2019 15:51:18 -0800 Subject: [PATCH 012/259] Need to debug a memory issue --- src/tracer/MOM_neutral_diffusion.F90 | 106 +++++++++++++-------------- 1 file changed, 53 insertions(+), 53 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 688a0bba16..def956195a 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1074,7 +1074,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ns = 4*nk ki_right = 1 ki_left = 1 - + kl_left = 1 + kl_right = 1 reached_bottom = .false. searching_left_column = .false. searching_right_column = .false. @@ -1131,7 +1132,6 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, endif endif endif - if (searching_left_column) then ! Position of the right interface is known PoR(k_surface) = ki_right - 1. @@ -1160,6 +1160,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, dRdT_l(kl_left,1), dRdS_l(kl_left,1), & dRdT_l(kl_left,2), dRdS_l(kl_left,2) ) PoL(k_surface) = pos + KoL(k_surface) = kl_left if (CS%debug) then write(*,'(A,I2,A,E12.4,A,E12.4,A,E12.4)') "Searching left layer ", kl_left, & @@ -1175,7 +1176,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! Position of the left interface is known PoL(k_surface) = ki_left - 1. KoL(k_surface) = kl_left - + ! Calculate difference in density between left top interface and right interface dRhoTop = calc_delta_rho(CS, & Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & @@ -1198,6 +1199,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, dRdT_r(kl_right,1), dRdS_r(kl_right,1), & dRdT_r(kl_right,2), dRdS_r(kl_right,2) ) PoR(k_surface) = pos + KoR(k_surface) = Kl_right 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 @@ -1210,9 +1212,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, else stop 'Else what?' endif + 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) endif - 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 ! This is useful as a check to make sure that positions are monotonically increasing @@ -1945,6 +1947,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) v = verbose ndiff_unit_tests_discontinuous = .false. ! Normally return false + CS%debug=.true. write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' ! h_neglect = 1.0e-30 ; h_neglect_edge = 1.0e-10 @@ -1955,64 +1958,61 @@ logical function ndiff_unit_tests_discontinuous(verbose) 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. ) - hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) ; Pres_l(1) = 0. ; Pres_r(1) = 0. + hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) Pres_l(1,1) = 0. ; Pres_l(1,2) = hL(1) ; Pres_r(1,1) = 0. ; Pres_r(1,2) = hR(1) do k = 2,nk Pres_l(k,1) = Pres_l(k-1,2) Pres_l(k,2) = Pres_l(k,1) + hL(k) Pres_r(k,1) = Pres_r(k-1,2) - Pres_r(k,2) = Pres_r(k-1,) + hR(k) + Pres_r(k,2) = Pres_r(k,1) + 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, 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 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(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 -! (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR -! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pL -! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pR -! (/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, 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 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(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 -! (/1,1,1,1,1,2,2,2,2,3,3,3/), & ! KoR -! (/0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0/), & ! pL -! (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pR -! (/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, 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 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(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 -! (/1,1,1,2,2,2,2,3,3,3,3,3/), & ! KoR -! (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pL -! (/0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0/), & ! pR -! (/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') + CS%delta_rho_form = 'no_pressure' + CS%neutral_pos_method = 1 + + ! For ease of coding up unit tests, we explicitly hard code temperatures at layer interfaces + TiL(1,:) = (/ 22., 18. /); TiL(2,:) = (/ 18., 14. /); TiL(3,:) = (/ 14., 10. /) + TiR(1,:) = (/ 22., 18. /); TiR(2,:) = (/ 18., 14. /); TiR(3,:) = (/ 14., 10. /) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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,2,2,2,2,3,3,3,3,3 /), & ! KoR + (/ 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0 /), & ! pL + (/ 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 1.0 /), & ! pR + (/ 0.0, 10., 0.0, 0.0, 0.0, 10., 0.0, 0.0, 0.0, 10., 0.0 /), & ! hEff + 'Identical columns') + TiL(1,:) = (/ 22., 18. /); TiL(2,:) = (/ 18., 14. /); TiL(3,:) = (/ 14., 10. /) + TiR(1,:) = (/ 20., 16. /); TiR(2,:) = (/ 16., 12. /); TiR(3,:) = (/ 12., 8.0 /) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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 + (/ 0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0 /), & ! pL + (/ 0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0 /), & ! pR + (/ 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0 /), & ! hEff + 'Right slightly cooler') + TiL(1,:) = (/ 22., 20. /); TiL(2,:) = (/ 18., 16. /); TiL(3,:) = (/ 14., 12. /) + TiR(1,:) = (/ 32., 24. /); TiR(2,:) = (/ 22., 14. /); TiR(3,:) = (/ 12., 4. /) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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,3,3,3,3,3 /), & ! KoL + (/ 1,1,2,2,2,2,2,2,3,3,3,3 /), & ! KoR + (/ 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 0.0, 1.0, 1.0, 1.0 /), & ! pL + (/ 0.0, 1.0, 0.0, 0.0, .25, 0.5, .75, 1.0, 0.0, 0.0, 0.0, 1.0 /), & ! pR + (/ 0.0, 0.0, 0.0, 4.0, 0.0, 4.0, 0.0, 0.0, 0.0, 0.0, 0.0 /), & ! hEff + 'Right more strongly stratified') ! Tl = (/20.,16.,12./) ; Tr = (/14.,10.,6./) ! 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 ) From a3d301796e54d9d43263fb150d303170d01b1238 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 3 Jan 2019 00:17:55 +0000 Subject: [PATCH 013/259] Remove unused variables --- src/tracer/MOM_neutral_diffusion.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index def956195a..092ed929f4 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1062,12 +1062,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target logical :: search_layer - 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 - real :: T_other, S_other, P_other, dRdT_other, dRdS_other real :: pos ! Initialize variables for the search From 0ffa3e67b75c2a2d06d317f505b5607a7d8e6009 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sat, 5 Jan 2019 00:48:48 +0000 Subject: [PATCH 014/259] Need to verify unit tests --- src/tracer/MOM_neutral_diffusion.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 092ed929f4..b62a49280b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1213,17 +1213,14 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, endif ! Effective thickness 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) - ! Check to see if neutral surfaces have crossed if hL or hR is negative - if ( hL<0. .or. hR<0. ) then - hEff(k_surface-1) = 0. - call MOM_error(FATAL, "hL or hR is negative") - elseif ( hL > 0. .and. hR > 0.) then + if ( KoL(k_surface) == KoL(k_surface-1) .and. KoR(k_surface) == KoR(k_surface-1) ) 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 + if ( hL + hR == 0. ) then + hEff(k_surface-1) = 0. + else + hEff(k_surface-1) = 2. * ( (hL * hR) / ( hL + hR ) )! Harmonic mean + endif else hEff(k_surface-1) = 0. endif From b8daf1ecf6c9649fa639f7b7d0681829f73495b2 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sun, 6 Jan 2019 16:09:38 -0800 Subject: [PATCH 015/259] Discontinuous unit tests all pass Updated so that all discontinuous unit tests match that of the python notebook --- src/tracer/MOM_neutral_diffusion.F90 | 474 ++++++++++++++++----------- 1 file changed, 278 insertions(+), 196 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b62a49280b..663f1c51e4 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1021,37 +1021,33 @@ end subroutine find_neutral_surface_positions_continuous subroutine find_neutral_surface_positions_discontinuous(CS, nk, 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), intent(inout) :: CS !< Neutral diffusion control structure - integer, intent(in) :: nk !< Number of levels - real, dimension(nk,2), 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,2), 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) - 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 - !! layer KoR of right column - integer, dimension(4*nk), intent(inout) :: KoL !< Index of first left interface above neutral surface - integer, dimension(4*nk), intent(inout) :: KoR !< Index of first right interface above neutral surface - real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) - real, 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 + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure + integer, intent(in) :: nk !< Number of levels + real, dimension(nk,2), 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,2), 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) + 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 + !! layer KoR of right column + integer, dimension(4*nk), intent(inout) :: KoL !< Index of first left interface above neutral surface + integer, dimension(4*nk), intent(inout) :: KoR !< Index of first right interface above neutral surface + real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) + real, dimension(:,:), optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction + real, dimension(:,:), optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction + real, dimension(:,:), optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction + real, dimension(:,:), optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction ! Local variables integer :: ns ! Number of neutral surfaces @@ -1062,6 +1058,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target logical :: search_layer + logical :: poly_present ! True if all polynomial coefficients were passed real :: dRho, dRhoTop, dRhoBot, hL, hR real :: min_bound real :: pos @@ -1075,33 +1072,48 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, reached_bottom = .false. searching_left_column = .false. searching_right_column = .false. + ! Check if polynomials are present + poly_present = PRESENT( ppoly_T_l ) .and. PRESENT( ppoly_S_l ) .and. PRESENT( ppoly_T_r ) .and. PRESENT( ppoly_S_r) ! Loop over each neutral surface, working from top to bottom neutral_surfaces: do k_surface = 1, ns + if (k_surface == ns) then + PoL(k_surface) = 1. + PoR(k_surface) = 1. + KoL(k_surface) = nk + KoR(k_surface) = nk ! If the layers are unstable, then simply point the surface to the previous location - if (.not. stable_l(kl_left)) then - PoL(k_surface) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 - KoL(k_surface) = kl_left + elseif (.not. stable_l(kl_left)) then if (k_surface > 1) then + PoL(k_surface) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoL(k_surface) = kl_left PoR(k_surface) = PoR(k_surface-1) KoR(k_surface) = KoR(k_surface-1) else PoR(k_surface) = 0. KoR(k_surface) = 1 + PoL(k_surface) = 0. + KoL(k_Surface) = 1 endif call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) + searching_left_column = .true. + searching_right_column = .false. elseif (.not. stable_r(kl_right)) then ! Check the right layer for stability - PoR(k_surface) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 - KoR(k_surface) = kl_right if (k_surface > 1) then + PoR(k_surface) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 + KoR(k_surface) = kl_right PoL(k_surface) = PoL(k_surface-1) KoL(k_surface) = KoL(k_surface-1) else + PoR(k_surface) = 0. + KoR(k_surface) = 1 PoL(k_surface) = 0. KoL(k_surface) = 1 endif call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) + searching_left_column = .false. + searching_right_column = .true. else ! Layers are stable so need to figure out whether we need to search right or left drho = calc_delta_rho(CS, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & @@ -1135,10 +1147,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! Calculate difference in density between left top interface and right interface dRhoTop = calc_delta_rho(CS, & - Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & - dRdT_l(kl_left,1), dRdS_l(kl_left,1), & - dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) + Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & + dRdT_l(kl_left,1), dRdS_l(kl_left,1), & + dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) ! Calculate difference in density between left bottom interface and right interface dRhoBot = calc_delta_rho(CS, & Tl(kl_left,2), Sl(kl_left,2), Pres_l(kl_left,2), & @@ -1148,13 +1160,27 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_right, k_surface) - if (pos < 0.) pos = neutral_pos(CS, dRhoTop, dRhoBot, & - Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& - dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & - ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), & - Pres_l(kl_left,1), Pres_l(kl_left,2), & - dRdT_l(kl_left,1), dRdS_l(kl_left,1), & - dRdT_l(kl_left,2), dRdS_l(kl_left,2) ) + if (pos < 0.) then + if (poly_present) then + ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments + pos = neutral_pos(CS, dRhoTop, dRhoBot, & + Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& + dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & + Pres_l(kl_left,1), Pres_l(kl_left,2), & + dRdT_l(kl_left,1), dRdS_l(kl_left,1), & + dRdT_l(kl_left,2), dRdS_l(kl_left,2), & + ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:) ) + else + pos = neutral_pos(CS, dRhoTop, dRhoBot, & + Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& + dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & + Pres_l(kl_left,1), Pres_l(kl_left,2), & + dRdT_l(kl_left,1), dRdS_l(kl_left,1), & + dRdT_l(kl_left,2), dRdS_l(kl_left,2) ) + endif + endif + + PoL(k_surface) = pos KoL(k_surface) = kl_left @@ -1174,26 +1200,38 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoL(k_surface) = kl_left ! Calculate difference in density between left top interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & - dRdT_r(kl_right,1), dRdS_r(kl_right,1), & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) + dRhoTop = calc_delta_rho(CS, & + Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), & + dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) ! Calculate difference in density between left bottom interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & - dRdT_r(kl_right,2), dRdS_r(kl_right,2) , & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) + dRhoBot = calc_delta_rho(CS, & + Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & + dRdT_r(kl_right,2), dRdS_r(kl_right,2) , & + dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) - if (pos < 0.) pos = neutral_pos(CS, dRhoTop, dRhoBot, & - Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & - dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & - ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:), & - Pres_r(kl_right,1), Pres_r(kl_right,2), & - dRdT_r(kl_right,1), dRdS_r(kl_right,1), & - dRdT_r(kl_right,2), dRdS_r(kl_right,2) ) + if (pos < 0.) then + ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments + if (poly_present) then + pos = neutral_pos(CS, dRhoTop, dRhoBot, & + Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & + dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & + Pres_r(kl_right,1), Pres_r(kl_right,2), & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), & + dRdT_r(kl_right,2), dRdS_r(kl_right,2), & + ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:) ) + else + pos = neutral_pos(CS, dRhoTop, dRhoBot, & + Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & + dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & + Pres_r(kl_right,1), Pres_r(kl_right,2), & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), & + dRdT_r(kl_right,2), dRdS_r(kl_right,2) ) + endif + endif PoR(k_surface) = pos KoR(k_surface) = Kl_right if (CS%debug) then @@ -1325,7 +1363,7 @@ end subroutine increment_interface !! 3. Keep recalculating alpha and beta (no pressure dependence), rootfinding for 0. position !! 4. Full nonlinear equation of state real function neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & - Tpoly, Spoly, P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot) & + P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot,Tpoly, Spoly) & result(pos) type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure real, optional :: dRhoTop !< delta rho at top interface @@ -1335,14 +1373,14 @@ real function neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, d real, optional :: P_ref !< Pressure of other interface real, optional :: dRdT_ref !< drho/dT of other interface real, optional :: dRdS_ref !< drho/dS of other interface - real, optional, dimension(CS%deg+1) :: Tpoly !< Temperature polynomial reconstruction - real, optional, dimension(CS%deg+1) :: Spoly !< Temperature polynomial reconstruction real, optional :: P_top !< Pressure at top interface real, optional :: P_bot !< Pressure at bottom interface real, optional :: dRdT_top !< drho/dT at cell's top interface real, optional :: dRdS_top !< drho/dS at cell's top interface real, optional :: dRdT_bot !< drho/dT at cell's bottom interface real, optional :: dRdS_bot !< drho/dS at cell's bottom interface + real, optional, dimension(CS%deg+1) :: Tpoly !< Temperature polynomial reconstruction + real, optional, dimension(CS%deg+1) :: Spoly !< Salinity polynomial reconstruction if (CS%neutral_pos_method == 1) then pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) @@ -1382,10 +1420,11 @@ real function calc_delta_rho(CS, T1, S1, p1_in, T2, S2, p2_in, drdt1, drds1, drd ! Use the full linear equation of state to calculate the difference in density (expensive!) if (CS%delta_rho_form == 'full') then - call calculate_density( T1, S1, p1, rho1, CS%EOS ) - call calculate_density( T2, S2, p2, rho2, CS%EOS ) + pmid = 0.5 * (p1 + p2) + call calculate_density( T1, S1, pmid, rho1, CS%EOS ) + call calculate_density( T2, S2, pmid, rho2, CS%EOS ) delta_rho = rho1 - rho2 - ! Use a linearized version of the equation of state + ! Use alpha and beta (without pressure dependence) elseif (CS%delta_rho_form == 'no_pressure') then if (.not. (PRESENT(drdt1) .and. PRESENT(drds1) .and. present(drdt2) .and. present(drds2)) ) then call MOM_error(FATAL,"DELTA_RHO_FORM == linear requires drdt and drds") @@ -1940,7 +1979,6 @@ logical function ndiff_unit_tests_discontinuous(verbose) v = verbose ndiff_unit_tests_discontinuous = .false. ! Normally return false - CS%debug=.true. write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' ! h_neglect = 1.0e-30 ; h_neglect_edge = 1.0e-10 @@ -1967,131 +2005,175 @@ logical function ndiff_unit_tests_discontinuous(verbose) CS%neutral_pos_method = 1 ! For ease of coding up unit tests, we explicitly hard code temperatures at layer interfaces - TiL(1,:) = (/ 22., 18. /); TiL(2,:) = (/ 18., 14. /); TiL(3,:) = (/ 14., 10. /) - TiR(1,:) = (/ 22., 18. /); TiR(2,:) = (/ 18., 14. /); TiR(3,:) = (/ 14., 10. /) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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,2,2,2,2,3,3,3,3,3 /), & ! KoR - (/ 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 1.0 /), & ! pL - (/ 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 1.0 /), & ! pR - (/ 0.0, 10., 0.0, 0.0, 0.0, 10., 0.0, 0.0, 0.0, 10., 0.0 /), & ! hEff - 'Identical columns') - TiL(1,:) = (/ 22., 18. /); TiL(2,:) = (/ 18., 14. /); TiL(3,:) = (/ 14., 10. /) - TiR(1,:) = (/ 20., 16. /); TiR(2,:) = (/ 16., 12. /); TiR(3,:) = (/ 12., 8.0 /) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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 - (/ 0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0 /), & ! pL - (/ 0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0 /), & ! pR - (/ 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0 /), & ! hEff - 'Right slightly cooler') - TiL(1,:) = (/ 22., 20. /); TiL(2,:) = (/ 18., 16. /); TiL(3,:) = (/ 14., 12. /) - TiR(1,:) = (/ 32., 24. /); TiR(2,:) = (/ 22., 14. /); TiR(3,:) = (/ 12., 4. /) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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,3,3,3,3,3 /), & ! KoL - (/ 1,1,2,2,2,2,2,2,3,3,3,3 /), & ! KoR - (/ 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 0.0, 1.0, 1.0, 1.0 /), & ! pL - (/ 0.0, 1.0, 0.0, 0.0, .25, 0.5, .75, 1.0, 0.0, 0.0, 0.0, 1.0 /), & ! pR - (/ 0.0, 0.0, 0.0, 4.0, 0.0, 4.0, 0.0, 0.0, 0.0, 0.0, 0.0 /), & ! hEff - 'Right more strongly stratified') -! Tl = (/20.,16.,12./) ; Tr = (/14.,10.,6./) -! 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 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(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 -! (/1,1,1,1,1,1,1,2,2,2,3,3/), & ! KoR -! (/0.0, 1.0, 0.0, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.0, 1.0/), & ! pL -! (/0.0, 0.0, 0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0, 0.0, 1.0/), & ! pR -! (/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, 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 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(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 -! (/1,1,1,1,1,1,1,1,2,2,3,3/), & ! KoR -! (/0.0, 1.0, 0.0, 1.0, 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0/), & ! pL -! (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0/), & ! pR -! (/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, 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 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(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 -! (/1,1,1,1,2,2,2,2,3,3,3,3/), & ! KoR -! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pL -! (/0.,0.,1.,1.,0.,0.,1.,1.,0.,0.,1.,1./), & ! pR -! (/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, 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 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(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 -! (/1,1,1,1,1,1,2,2,2,3,3,3/), & ! KoR -! (/0.0, 1.0, 0.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.5, 1.0, 1.0/), & ! pL -! (/0.0, 0.0, 0.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 0.0, 0.5, 1.0/), & ! pR -! (/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, 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 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(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 -! (/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, 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') -! -! 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, 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(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 -! (/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) + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical Columns') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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 + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Right slightly cooler') + + TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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 + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left slightly cooler') + + TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); + TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 0.00, 0.25, 0.50, 0.75, 1.00, 0.00, 0.00, 0.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right more strongly stratified') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Deep Mixed layer on the right') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.25, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical columns with mixed layer') + + TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); + TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Left interior unstratified') + + TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); + TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left mixed layer, Right unstable interior') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 0.75, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Left thick mixed layer, Right unstable mixed') + + TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Unstable mixed layers, left cooler') + + deallocate(remap_CS) ! ! allocate(EOS) ! call EOS_manual_init(EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 2.) From 3871608a3477d4a8b1bdea77778ec1b8ca58c1fd Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sun, 6 Jan 2019 17:20:19 -0800 Subject: [PATCH 016/259] Add linear alpha/beta neutral pos - Pulled in changes from a different branch containing the new routine where we assume alpha and beta vary linearly from the top and bottom of a cell - Deprecate most of neutral_diffusion_aux - Fix unit tests for find_neutral_pos_linear --- src/tracer/MOM_neutral_diffusion.F90 | 253 ++++++++++++++++------- src/tracer/MOM_neutral_diffusion_aux.F90 | 132 ------------ 2 files changed, 183 insertions(+), 202 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ad36ce2af0..54512de1e3 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -8,16 +8,12 @@ module MOM_neutral_diffusion 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 : calculate_density, 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 : ndiff_aux_CS_type, set_ndiff_aux_params -use MOM_neutral_diffusion_aux, only : calc_drho, drho_at_pos -use MOM_neutral_diffusion_aux, only : 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 @@ -43,7 +39,8 @@ module MOM_neutral_diffusion logical :: continuous_reconstruction = .true. !< True if using continuous PPM reconstruction at interfaces logical :: debug = .false. !< If true, write verbose debugging messages integer :: max_iter !< Maximum number of iterations if refine_position is defined - real :: tolerance !< Convergence criterion representing difference from true neutrality + real :: drho_tol!< Convergence criterion representing difference from true neutrality + real :: x_tol !< Convergence criterion for how small an update of the position can be real :: ref_pres !< Reference pressure, negative if using locally referenced neutral density ! Positions of neutral surfaces in both the u, v directions @@ -89,7 +86,6 @@ module MOM_neutral_diffusion real :: C_p !< heat capacity of seawater (J kg-1 K-1) type(EOS_type), pointer :: EOS !< Equation of state parameters type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers - type(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". @@ -111,9 +107,6 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) 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.") @@ -132,7 +125,6 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) endif allocate(CS) - allocate(CS%ndiff_aux_CS) CS%diag => diag CS%EOS => EOS ! call openParameterBlock(param_file,'NEUTRAL_DIFF') @@ -182,25 +174,23 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) " pressure dependence", & default="no_pressure") if (CS%neutral_pos_method > 1) then - call get_param(param_file, mdl, "NDIFF_DRHO_TOL", drho_tol, & + call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%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_X_TOL", xtol, & + call get_param(param_file, mdl, "NDIFF_X_TOL", CS%x_tol, & "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, & + call get_param(param_file, mdl, "NDIFF_MAX_ITER", CS%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 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, & @@ -1011,6 +1001,43 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS enddo neutral_surfaces end subroutine find_neutral_surface_positions_continuous +!> 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 + !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S @@ -1056,8 +1083,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: search_layer logical :: poly_present ! True if all polynomial coefficients were passed real :: dRho, dRhoTop, dRhoBot, hL, hR - real :: min_bound - real :: pos + real :: z0, pos ! Initialize variables for the search ns = 4*nk @@ -1157,9 +1183,14 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_right, k_surface) if (pos < 0.) then + if (kl_left == KoL(k_surface-1)) then + z0 = PoL(k_surface-1) + else + z0 = 0. + endif if (poly_present) then ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments - pos = neutral_pos(CS, dRhoTop, dRhoBot, & + pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & Pres_l(kl_left,1), Pres_l(kl_left,2), & @@ -1167,7 +1198,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, dRdT_l(kl_left,2), dRdS_l(kl_left,2), & ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:) ) else - pos = neutral_pos(CS, dRhoTop, dRhoBot, & + pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & Pres_l(kl_left,1), Pres_l(kl_left,2), & @@ -1209,9 +1240,14 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) if (pos < 0.) then + if (kl_right == KoR(k_surface-1)) then + z0 = PoR(k_surface-1) + else + z0 = 0. + endif ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments if (poly_present) then - pos = neutral_pos(CS, dRhoTop, dRhoBot, & + pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & Pres_r(kl_right,1), Pres_r(kl_right,2), & @@ -1219,7 +1255,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, dRdT_r(kl_right,2), dRdS_r(kl_right,2), & ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:) ) else - pos = neutral_pos(CS, dRhoTop, dRhoBot, & + pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & Pres_r(kl_right,1), Pres_r(kl_right,2), & @@ -1259,28 +1295,6 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, endif endif enddo neutral_surfaces -! if (CS%debug) then -! 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 -! write(*,'(A,E16.6)') "Total thickness of sublayers: ", SUM(hEff) -! write(*,*) "==========End Neutral Surfaces==========" -! endif - end subroutine find_neutral_surface_positions_discontinuous !> Sweep down through the column and mark as stable if the bottom interface of a cell is denser than the top @@ -1357,10 +1371,11 @@ end subroutine increment_interface !! 2. Alpha and beta vary linearly from top to bottom, rootfinding for 0. position !! 3. Keep recalculating alpha and beta (no pressure dependence), rootfinding for 0. position !! 4. Full nonlinear equation of state -real function neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & - P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot,Tpoly, Spoly) & +real function neutral_pos(CS, z0, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & + P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot, Tpoly, Spoly ) & result(pos) type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure + real, optional :: z0 !< Initial guess (0. or previous pos) real, optional :: dRhoTop !< delta rho at top interface real, optional :: dRhoBot !< delta rho at bottom interface real, optional :: T_ref !< Temperature of other interface @@ -1374,13 +1389,14 @@ real function neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, d real, optional :: dRdS_top !< drho/dS at cell's top interface real, optional :: dRdT_bot !< drho/dT at cell's bottom interface real, optional :: dRdS_bot !< drho/dS at cell's bottom interface - real, optional, dimension(CS%deg+1) :: Tpoly !< Temperature polynomial reconstruction - real, optional, dimension(CS%deg+1) :: Spoly !< Salinity polynomial reconstruction + real, optional, dimension(:) :: Tpoly !< Temperature polynomial reconstruction + real, optional, dimension(:) :: Spoly !< Salinity polynomial reconstruction - if (CS%neutral_pos_method == 1) then + if (CS%neutral_pos_method == 1) then pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) elseif (CS%neutral_pos_method == 2) then - call MOM_error(FATAL,"neutral_pos_method 2 has yet to be implemented") + pos = find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT_top, dRdS_top, & + dRdT_bot, dRdT_bot, Tpoly, Spoly ) elseif (CS%neutral_pos_method == 3) then ! pos = refine_nondim_position(CS, T_ref, S_ref, dRdT_ref, dRdS_ref, P_top, P_bot, & ! Tpoly, Spoly, dRhoTop, dRhoBot, 0.) @@ -1389,6 +1405,105 @@ real function neutral_pos(CS, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, d endif end function neutral_pos +!> Search a layer to find where delta_rho = 0 based on a linear interpolation of alpha and beta of the top and bottom +!! being searched and polynomial reconstructions of T and S. We need Newton's method because the T and S +!! reconstructions make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search +!! fall out of the interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta +!! means that second derivatives of the EOS are not needed. Note that delta in variable names below refers to +!! horizontal differences and 'd' refers to vertical differences +function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT_top, dRdS_top, & + dRdT_bot, dRdS_bot, ppoly_T, ppoly_S ) result( z ) + type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module + real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess + real, intent(in) :: T_ref !< Temperature at the searched from interface + real, intent(in) :: S_ref !< Salinity at the searched from interface + real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface + real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface + real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched + real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched + real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched + real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched + real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within + !! the layer to be searched. + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within + !! the layer to be searched. + real :: z !< Position where drho = 0 + ! Local variables + real :: dRdT_diff, dRdS_diff, drho, drho_dz, dRdT_z, dRdS_z, T_z, S_z, deltaT, deltaS, dT_dz, dS_dz + real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dz + real :: a1, a2 + integer :: iter + integer :: nterm + + nterm = SIZE(ppoly_T) + + ! Position independent quantities + dRdT_diff = dRdT_bot - dRdT_top + dRdS_diff = dRdS_bot - dRdS_top + ! Initial starting drho (used for bisection) + zmin = z0 ! Lower bounding interval + zmax = 1. ! Maximum bounding interval (bottom of layer) + T_z = evaluation_polynomial( ppoly_T, nterm, zmin ) + S_z = evaluation_polynomial( ppoly_S, nterm, zmin ) + drho_min = 0.5 * ( (dRdT_top + dRdT_ref )*(T_z - T_ref) + (dRdS_top + dRdS_ref)*(S_z - S_ref) ) + T_z = evaluation_polynomial( ppoly_T, nterm, zmax ) + S_z = evaluation_polynomial( ppoly_S, nterm, zmax ) + drho_max = 0.5 * ( (dRdT_bot + dRdT_ref )*(T_z - T_ref) + (dRdS_bot + dRdS_ref)*(S_z - S_ref) ) + + z = z0 + + do iter = 1, CS%max_iter + ! Calculate quantities at the current nondimensional position + a1 = 1.-z + a2 = z + dRdT_z = a1*dRdT_top + a2*dRdT_bot + dRdS_z = a1*dRdS_top + a2*dRdS_bot + T_z = evaluation_polynomial( ppoly_T, nterm, z ) + S_z = evaluation_polynomial( ppoly_S, nterm, z ) + deltaT = T_z - T_ref + deltaS = S_z - S_ref + dRdT_sum = dRdT_ref + dRdT_z + dRdS_sum = dRdS_ref + dRdS_z + drho = 0.5 * ( dRdT_sum*deltaT + dRdS_sum*deltaS ) + + ! Check to make sure that the position at z0 is negative, otherwise the starting position should be returned + if (iter == 1 .and. drho > 0.) return + + ! Check for convergence + if (ABS(drho) <= CS%drho_tol) exit + ! Update bisection bracketing intervals + if (drho < 0. .and. drho > drho_min) then + drho_min = drho + zmin = z + elseif (drho > 0. .and. drho < drho_max) then + drho_max = drho + zmax = z + endif + + ! Calculate a Newton step + dT_dz = first_derivative_polynomial( ppoly_T, nterm, z ) + dS_dz = first_derivative_polynomial( ppoly_S, nterm, z ) + drho_dz = 0.5*( (dRdT_diff*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) ) + + ztest = z - drho/drho_dz + ! Take a bisection if z falls out of [zmin,zmax] + if (ztest < zmin .or. ztest > zmax) then + if ( drho < 0. ) then + ztest = 0.5*(z + zmax) + else + ztest = 0.5*(zmin + z) + endif + endif + + ! Test to ensure we haven't stalled out + if ( abs(z-ztest) <= CS%x_tol ) exit + + ! Reset for next iteration + z = ztest + enddo + +end function find_neutral_pos_linear + !> Calculate the difference in density between two points in a variety of ways real function calc_delta_rho(CS, T1, S1, p1_in, T2, S2, p2_in, drdt1, drds1, drdt2, drds2 ) result(delta_rho) type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure @@ -2173,55 +2288,53 @@ 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( & -! CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/35., 0./), -1., 1., 0.), & +! 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( & -! CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/20., 0./), (/34., 2./), -2., 2., 0.), & +! 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( & -! CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & +! 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( & -! CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/35., 0./), -1., 1., 0.), & +! 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( & -! CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/20., 0./), (/34., 2./), -2., 2., 0.), & +! 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( & -! CS%ndiff_aux_CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & +! CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & ! "Temp/Salt stratified (Brent) ")) ! deallocate(EOS) ! ! Tests for linearized version of searching the layer for neutral surface position ! EOS linear in T, uniform alpha + CS%max_iter = 10 ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.2, 0., -0.2, 0., -0.2, 0., & - (/12.,-4./), (/34.,0./), 0.), "Temp Uniform Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., -0.2, 0., -0.2, 0., & + (/12.,-4./), (/34.,0./)), "Temp Uniform Linearized Alpha/Beta")) ! EOS linear in S, uniform beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., 0., 0.8, 0., 0.8, 0., 0.8, & - (/12.,0./), (/34.,2./), 0.), "Salt Uniform Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 0.8, 0., 0.8, & + (/12.,0./), (/34.,2./)), "Salt Uniform Linearized Alpha/Beta")) ! EOS linear in T/S, uniform alpha/beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.5, 0.5, -0.5, 0.5, -0.5, 0.5, & - (/12.,-4./), (/34.,2./), 0.), "Temp/salt Uniform Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., -0.5, 0.5, -0.5, 0.5, -0.5, 0.5, & + (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) ! EOS linear in T, insensitive to S ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., -0.2, 0., -0.4, 0., -0.6, 0., & - (/12.,-4./), (/34.,0./), 0.), "Temp stratified Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., -0.4, 0., -0.6, 0., & + (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) ! EOS linear in S, insensitive to T ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear_alpha_beta(CS%ndiff_aux_CS, 10., 35., 0., 0.8, 0., 1.0, 0., 0.5, & - (/12.,0./), (/34.,2./), 0.), "Salt stratified Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 1.0, 0., 0.5, & + (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' deallocate(EOS) - deallocate(CS%ndiff_aux_CS end function ndiff_unit_tests_discontinuous @@ -2469,7 +2582,7 @@ logical function test_rnp(expected_pos, test_pos, title) character(len=*), intent(in) :: title !< A label for this test ! Local variables integer :: stdunit = 6 ! Output to standard error - test_rnp = expected_pos /= test_pos + test_rnp = ABS(expected_pos - test_pos) > 2*EPSILON(test_pos) if (test_rnp) then write(stdunit,'(A, f20.16, " .neq. ", f20.16, " <-- WRONG")') title, expected_pos, test_pos else diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 6e8466bc58..0b23baae29 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -12,8 +12,6 @@ module MOM_neutral_diffusion_aux public set_ndiff_aux_params public calc_drho public drho_at_pos -public interpolate_for_nondim_position -public find_neutral_pos_linear_alpha_beta public refine_nondim_position public check_neutral_positions public kahan_sum @@ -124,136 +122,6 @@ subroutine drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppol end subroutine drho_at_pos -!> 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 - -!> Search a layer to find where delta_rho = 0 based on a linear interpolation of alpha and beta of the top and bottom -!! being searched and polynomial reconstructions of T and S. We need Newton's method because the T and S -!! reconstructions make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search -!! fall out of the interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta -!! means that second derivatives of the EOS are not needed. Note that delta in variable names below refers to -!! horizontal differences and 'd' refers to vertical differences -function find_neutral_pos_linear_alpha_beta( CS, T_ref, S_ref, alpha_ref, beta_ref, alpha_top, beta_top, & - alpha_bot, beta_bot, ppoly_T, ppoly_S, z0 ) result( z ) - 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) :: alpha_top !< dRho/dT at top of layer being searched - real, intent(in) :: beta_top !< dRho/dS at top of layer being searched - real, intent(in) :: alpha_bot !< dRho/dT at bottom of layer being searched - real, intent(in) :: beta_bot !< dRho/dS at bottom of layer being 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) :: z0 !< Lower bound of position, also serves as the initial guess - real :: z !< Position where drho = 0 - ! Local variables - real :: dalpha, dbeta, drho, drho_dz, alpha_z, beta_z, T_z, S_z, deltaT, deltaS, dT_dz, dS_dz, alpha_sum, beta_sum, dz - real :: drho_min, drho_max, ztest, zmin, zmax - real :: a1, a2 - integer :: iter - - ! Position independent quantities - dalpha = alpha_bot - alpha_top - dbeta = beta_bot - beta_top - ! Initial starting drho (used for bisection) - zmin = z0 ! Lower bounding interval - zmax = 1. ! Maximum bounding interval (bottom of layer) - T_z = evaluation_polynomial( ppoly_T, CS%nterm, zmin ) - S_z = evaluation_polynomial( ppoly_S, CS%nterm, zmin ) - drho_min = 0.5 * ( (alpha_top + alpha_ref )*(T_z - T_ref) + (beta_top + beta_ref)*(S_z - S_ref) ) - T_z = evaluation_polynomial( ppoly_T, CS%nterm, zmax ) - S_z = evaluation_polynomial( ppoly_S, CS%nterm, zmax ) - drho_max = 0.5 * ( (alpha_bot + alpha_ref )*(T_z - T_ref) + (beta_bot + beta_ref)*(S_z - S_ref) ) - - z = z0 - do iter = 1, CS%max_iter - ! Calculate quantities at the current nondimensional position - a1 = 1.-z - a2 = z - alpha_z = a1*alpha_top + a2*alpha_bot - beta_z = a1*beta_top + a2*beta_bot - T_z = evaluation_polynomial( ppoly_T, CS%nterm, z ) - S_z = evaluation_polynomial( ppoly_S, CS%nterm, z ) - deltaT = T_z - T_ref - deltaS = S_z - S_ref - alpha_sum = alpha_ref + alpha_z - beta_sum = beta_ref + beta_z - drho = 0.5 * ( alpha_sum*deltaT + beta_sum*deltaS ) - ! Check for convergence - if (ABS(drho) <= CS%drho_tol) exit - ! Update bisection bracketing intervals - if (drho < 0. .and. drho > drho_min) then - drho_min = drho - zmin = z - elseif (drho > 0. .and. drho < drho_max) then - drho_max = drho - zmax = z - endif - - ! Calculate a Newton step - dT_dz = first_derivative_polynomial( ppoly_T, CS%nterm, z ) - dS_dz = first_derivative_polynomial( ppoly_S, CS%nterm, z ) - drho_dz = 0.5*( (dalpha*deltaT + alpha_sum*dT_dz) + (dbeta*deltaS + beta_sum*dS_dz) ) - - ztest = z - drho/drho_dz - print *, ztest, z, drho, drho_dz - - ! Take a bisection if z falls out of [zmin,zmax] - if (ztest < zmin .or. ztest > zmax) then - if ( drho < 0. ) then - ztest = 0.5*(z + zmax) - else - ztest = 0.5*(zmin + z) - endif - endif - - ! Test to ensure we haven't stalled out - if ( abs(z-ztest) <= CS%xtol ) exit - - ! Reset for next iteration - z = ztest - enddo - -end function find_neutral_pos_linear_alpha_beta - !> 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, From 9f6d8b9b7aeb17ecffa89dafa7aeb5bc229af1fb Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sun, 6 Jan 2019 21:29:37 -0800 Subject: [PATCH 017/259] Fix Travis-related errors --- src/tracer/MOM_neutral_diffusion.F90 | 103 +++++++++++++-------------- 1 file changed, 51 insertions(+), 52 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 54512de1e3..1c5960516b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -40,7 +40,7 @@ module MOM_neutral_diffusion logical :: debug = .false. !< If true, write verbose debugging messages integer :: max_iter !< Maximum number of iterations if refine_position is defined real :: drho_tol!< Convergence criterion representing difference from true neutrality - real :: x_tol !< Convergence criterion for how small an update of the position can be + real :: x_tol !< Convergence criterion for how small an update of the position can be real :: ref_pres !< Reference pressure, negative if using locally referenced neutral density ! Positions of neutral surfaces in both the u, v directions @@ -79,7 +79,7 @@ module MOM_neutral_diffusion !! regulate the timing of diagnostic output. integer :: neutral_pos_method !< Method to find the position of a neutral surface within the layer character(len=40) :: delta_rho_form - + integer :: id_uhEff_2d = -1 !< Diagnostic IDs integer :: id_vhEff_2d = -1 !< Diagnostic IDs @@ -1088,7 +1088,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! Initialize variables for the search ns = 4*nk ki_right = 1 - ki_left = 1 + ki_left = 1 kl_left = 1 kl_right = 1 reached_bottom = .false. @@ -1108,7 +1108,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! If the layers are unstable, then simply point the surface to the previous location elseif (.not. stable_l(kl_left)) then if (k_surface > 1) then - PoL(k_surface) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 + PoL(k_surface) = ki_left - 1 ! Top interface is at position = 0., Bottom is at position = 1 KoL(k_surface) = kl_left PoR(k_surface) = PoR(k_surface-1) KoR(k_surface) = KoR(k_surface-1) @@ -1123,7 +1123,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, searching_right_column = .false. elseif (.not. stable_r(kl_right)) then ! Check the right layer for stability if (k_surface > 1) then - PoR(k_surface) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 + PoR(k_surface) = ki_right - 1 ! Top interface is at position = 0., Bottom is at position = 1 KoR(k_surface) = kl_right PoL(k_surface) = PoL(k_surface-1) KoL(k_surface) = KoL(k_surface-1) @@ -1141,7 +1141,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & Tl(kl_left, ki_left) , Sl(kl_left, ki_left) , Pres_l(kl_left, ki_left), & dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left, ki_left)) + dRdT_l(kl_left, ki_left), dRdS_l(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 ! Which column has the lighter surface for the current indexes, kr and kl @@ -1189,7 +1189,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, z0 = 0. endif if (poly_present) then - ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments + ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & @@ -1217,14 +1217,14 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, 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) write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) - endif + endif call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) elseif (searching_right_column) then ! Position of the left interface is known PoL(k_surface) = ki_left - 1. KoL(k_surface) = kl_left - + ! Calculate difference in density between left top interface and right interface dRhoTop = calc_delta_rho(CS, & Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & @@ -1245,14 +1245,14 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, else z0 = 0. endif - ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments + ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments if (poly_present) then pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & Pres_r(kl_right,1), Pres_r(kl_right,2), & dRdT_r(kl_right,1), dRdS_r(kl_right,1), & - dRdT_r(kl_right,2), dRdS_r(kl_right,2), & + dRdT_r(kl_right,2), dRdS_r(kl_right,2), & ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:) ) else pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & @@ -1272,7 +1272,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, write(*,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) write(*,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) write(*,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) - endif + endif call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) else stop 'Else what?' @@ -1376,21 +1376,21 @@ real function neutral_pos(CS, z0, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_re result(pos) type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure real, optional :: z0 !< Initial guess (0. or previous pos) - real, optional :: dRhoTop !< delta rho at top interface - real, optional :: dRhoBot !< delta rho at bottom interface - real, optional :: T_ref !< Temperature of other interface - real, optional :: S_ref !< Salinity of other interface - real, optional :: P_ref !< Pressure of other interface - real, optional :: dRdT_ref !< drho/dT of other interface - real, optional :: dRdS_ref !< drho/dS of other interface - real, optional :: P_top !< Pressure at top interface - real, optional :: P_bot !< Pressure at bottom interface - real, optional :: dRdT_top !< drho/dT at cell's top interface - real, optional :: dRdS_top !< drho/dS at cell's top interface - real, optional :: dRdT_bot !< drho/dT at cell's bottom interface - real, optional :: dRdS_bot !< drho/dS at cell's bottom interface - real, optional, dimension(:) :: Tpoly !< Temperature polynomial reconstruction - real, optional, dimension(:) :: Spoly !< Salinity polynomial reconstruction + real, optional :: dRhoTop !< delta rho at top interface + real, optional :: dRhoBot !< delta rho at bottom interface + real, optional :: T_ref !< Temperature of other interface + real, optional :: S_ref !< Salinity of other interface + real, optional :: P_ref !< Pressure of other interface + real, optional :: dRdT_ref !< drho/dT of other interface + real, optional :: dRdS_ref !< drho/dS of other interface + real, optional :: P_top !< Pressure at top interface + real, optional :: P_bot !< Pressure at bottom interface + real, optional :: dRdT_top !< drho/dT at cell's top interface + real, optional :: dRdS_top !< drho/dS at cell's top interface + real, optional :: dRdT_bot !< drho/dT at cell's bottom interface + real, optional :: dRdS_bot !< drho/dS at cell's bottom interface + real, optional, dimension(:) :: Tpoly !< Temperature polynomial reconstruction + real, optional, dimension(:) :: Spoly !< Salinity polynomial reconstruction if (CS%neutral_pos_method == 1) then pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) @@ -2115,8 +2115,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) CS%neutral_pos_method = 1 ! For ease of coding up unit tests, we explicitly hard code temperatures at layer interfaces - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2129,8 +2129,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff 'Identical Columns') - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2143,8 +2143,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff 'Right slightly cooler') - TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2157,8 +2157,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff 'Left slightly cooler') - TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); - TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); + TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2171,8 +2171,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff 'Right more strongly stratified') - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2185,8 +2185,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff 'Deep Mixed layer on the right') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2199,8 +2199,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff 'Right unstratified column') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2213,8 +2213,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff 'Right unstratified column') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2227,8 +2227,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff 'Identical columns with mixed layer') - TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); - TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); + TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); + TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2241,8 +2241,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff 'Left interior unstratified') - TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); - TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); + TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); + TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2255,8 +2255,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff 'Left mixed layer, Right unstable interior') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2269,8 +2269,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff 'Left thick mixed layer, Right unstable mixed') - TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); + TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, dRdT, dRdS, stable_l, & @@ -2334,7 +2334,6 @@ logical function ndiff_unit_tests_discontinuous(verbose) find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 1.0, 0., 0.5, & (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' - deallocate(EOS) end function ndiff_unit_tests_discontinuous From 67955b2f2ef3232530f7201bca27785a1f7d650c Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 7 Jan 2019 09:57:06 -0800 Subject: [PATCH 018/259] Need to refactor delta_rho --- src/tracer/MOM_neutral_diffusion.F90 | 114 ++++++++++++++++----------- 1 file changed, 66 insertions(+), 48 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 1c5960516b..23ece3abb1 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1138,10 +1138,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, searching_right_column = .true. else ! Layers are stable so need to figure out whether we need to search right or left drho = calc_delta_rho(CS, & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & - Tl(kl_left, ki_left) , Sl(kl_left, ki_left) , Pres_l(kl_left, ki_left), & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), & + Tl(kl_left, ki_left), Sl(kl_left, ki_left) , & dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left, ki_left)) + dRdT_l(kl_left, ki_left), dRdS_l(kl_left, ki_left), & + Pres_r(kl_right, ki_right), Pres_l(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 ! Which column has the lighter surface for the current indexes, kr and kl @@ -1168,17 +1169,19 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoR(k_surface) = kl_right ! Calculate difference in density between left top interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & - dRdT_l(kl_left,1), dRdS_l(kl_left,1), & - dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) + dRhoTop = calc_delta_rho(CS, & + Tl(kl_left,1), Sl(kl_left,1), & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), & + dRdT_l(kl_left,1), dRdS_l(kl_left,1), & + dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & + Pres_l(kl_left,1), Pres_r(kl_right, ki_right)) ! Calculate difference in density between left bottom interface and right interface - dRhoBot = calc_delta_rho(CS, & - Tl(kl_left,2), Sl(kl_left,2), Pres_l(kl_left,2), & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & - dRdT_l(kl_left,2), dRdS_l(kl_left,2), & - dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right)) + dRhoBot = calc_delta_rho(CS, & + Tl(kl_left,2), Sl(kl_left,2), & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), & + dRdT_l(kl_left,2), dRdS_l(kl_left,2), & + dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & + Pres_l(kl_left,2), Pres_r(kl_right, ki_right)) ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_right, k_surface) @@ -1226,17 +1229,19 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoL(k_surface) = kl_left ! Calculate difference in density between left top interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & - dRdT_r(kl_right,1), dRdS_r(kl_right,1), & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) + dRhoTop = calc_delta_rho(CS, & + Tr(kl_right,1), Sr(kl_right,1), & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), & + dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left), & + Pres_r(kl_right,1), Pres_l(kl_left,ki_left)) ! Calculate difference in density between left bottom interface and right interface - dRhoBot = calc_delta_rho(CS, & - Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), Pres_l(kl_left,ki_left), & - dRdT_r(kl_right,2), dRdS_r(kl_right,2) , & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left)) + dRhoBot = calc_delta_rho(CS, & + Tr(kl_right,2), Sr(kl_right,2), & + Tl(kl_left,ki_left), Sl(kl_left,ki_left), & + dRdT_r(kl_right,2), dRdS_r(kl_right,2), & + dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left), & + Pres_r(kl_right,2), Pres_l(kl_left,ki_left)) ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) if (pos < 0.) then @@ -1312,8 +1317,8 @@ subroutine mark_unstable_cells(CS, nk, dRdT, dRdS, T, S, P, stable_cell) real :: delta_rho do k = 1,nk - stable_cell(k) = ( calc_delta_rho(CS, T(k,2), S(k,2), P(k,2), T(k,1), S(k,1), P(k,1), & - dRdT(k,2), dRdS(k,2), dRdT(k,1), dRdS(k,2)) > 0. ) + stable_cell(k) = ( calc_delta_rho(CS, T(k,2), S(k,2), T(k,1), S(k,1), & + dRdT(k,2), dRdS(k,2), dRdT(k,1), dRdS(k,2), P(k,2), P(k,1)) > 0. ) enddo end subroutine mark_unstable_cells @@ -1395,8 +1400,8 @@ real function neutral_pos(CS, z0, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_re if (CS%neutral_pos_method == 1) then pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) elseif (CS%neutral_pos_method == 2) then - pos = find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT_top, dRdS_top, & - dRdT_bot, dRdT_bot, Tpoly, Spoly ) + pos = find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_ref, dRdT_top, dRdS_top, P_top, & + dRdT_bot, dRdT_bot, P_bot, Tpoly, Spoly ) elseif (CS%neutral_pos_method == 3) then ! pos = refine_nondim_position(CS, T_ref, S_ref, dRdT_ref, dRdS_ref, P_top, P_bot, & ! Tpoly, Spoly, dRhoTop, dRhoBot, 0.) @@ -1411,18 +1416,21 @@ end function neutral_pos !! fall out of the interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta !! means that second derivatives of the EOS are not needed. Note that delta in variable names below refers to !! horizontal differences and 'd' refers to vertical differences -function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT_top, dRdS_top, & - dRdT_bot, dRdS_bot, ppoly_T, ppoly_S ) result( z ) +function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_ref, dRdT_top, dRdS_top, & + P_top, dRdT_bot, dRdS_bot, P_bot, ppoly_T, ppoly_S ) result( z ) type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess real, intent(in) :: T_ref !< Temperature at the searched from interface real, intent(in) :: S_ref !< Salinity at the searched from interface + real, intent(in) :: P_ref !< Pressure at the searched from interface real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched + real, intent(in) :: P_top !< Pressure at top of layer being searched real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched + real, intent(in) :: P_bot !< Pressure at bottom of layer being searched real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within !! the layer to be searched. real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within @@ -1430,7 +1438,7 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT real :: z !< Position where drho = 0 ! Local variables real :: dRdT_diff, dRdS_diff, drho, drho_dz, dRdT_z, dRdS_z, T_z, S_z, deltaT, deltaS, dT_dz, dS_dz - real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dz + real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dz, P_z real :: a1, a2 integer :: iter integer :: nterm @@ -1443,15 +1451,20 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT ! Initial starting drho (used for bisection) zmin = z0 ! Lower bounding interval zmax = 1. ! Maximum bounding interval (bottom of layer) + a1 = 1. - zmin + a2 = zmin T_z = evaluation_polynomial( ppoly_T, nterm, zmin ) S_z = evaluation_polynomial( ppoly_S, nterm, zmin ) - drho_min = 0.5 * ( (dRdT_top + dRdT_ref )*(T_z - T_ref) + (dRdS_top + dRdS_ref)*(S_z - S_ref) ) + dRdT_z = a1*dRdT_top + a2*dRdT_bot + dRdS_z = a1*dRdS_top + a2*dRdS_bot + P_z = a1*P_top + a2*P_bot + drho_min = calc_delta_rho(CS, T_z, S_z, dRdT_z, dRdS_z, T_ref, S_ref, dRdT_ref, dRdS_ref, P_z, P_ref) T_z = evaluation_polynomial( ppoly_T, nterm, zmax ) S_z = evaluation_polynomial( ppoly_S, nterm, zmax ) - drho_max = 0.5 * ( (dRdT_bot + dRdT_ref )*(T_z - T_ref) + (dRdS_bot + dRdS_ref)*(S_z - S_ref) ) + drho_max = calc_delta_rho(CS, T_z, S_z, dRdT_bot, dRdS_bot, T_ref, S_ref, dRdT_ref, dRdS_ref, P_bot, P_ref) z = z0 - + print *, z, drho_min, drho_max do iter = 1, CS%max_iter ! Calculate quantities at the current nondimensional position a1 = 1.-z @@ -1464,13 +1477,14 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT deltaS = S_z - S_ref dRdT_sum = dRdT_ref + dRdT_z dRdS_sum = dRdS_ref + dRdS_z - drho = 0.5 * ( dRdT_sum*deltaT + dRdS_sum*deltaS ) + drho = calc_delta_rho(CS, T_z, S_z, dRdT_z, dRdS_z, T_ref, S_ref, dRdT_ref, dRdS_ref, P_z, P_ref) + print *, "Iteration: ", iter ! Check to make sure that the position at z0 is negative, otherwise the starting position should be returned - if (iter == 1 .and. drho > 0.) return + if (iter == 1 .and. drho > 0.) exit ! Check for convergence - if (ABS(drho) <= CS%drho_tol) exit + if (ABS(drho) <= CS%drho_tol) exit ! Update bisection bracketing intervals if (drho < 0. .and. drho > drho_min) then drho_min = drho @@ -1479,6 +1493,8 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT drho_max = drho zmax = z endif + print *, z, zmin, zmax + print *, drho, drho_min, drho_max ! Calculate a Newton step dT_dz = first_derivative_polynomial( ppoly_T, nterm, z ) @@ -1488,35 +1504,37 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdT ztest = z - drho/drho_dz ! Take a bisection if z falls out of [zmin,zmax] if (ztest < zmin .or. ztest > zmax) then + print *, 'Bisection' if ( drho < 0. ) then ztest = 0.5*(z + zmax) else ztest = 0.5*(zmin + z) endif endif - + ! Test to ensure we haven't stalled out if ( abs(z-ztest) <= CS%x_tol ) exit ! Reset for next iteration z = ztest enddo + pause end function find_neutral_pos_linear !> Calculate the difference in density between two points in a variety of ways -real function calc_delta_rho(CS, T1, S1, p1_in, T2, S2, p2_in, drdt1, drds1, drdt2, drds2 ) result(delta_rho) +real function calc_delta_rho(CS, T1, S1, T2, S2, drdt1, drds1, drdt2, drds2, p1_in, p2_in ) result(delta_rho) type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure real, intent(in) :: T1 !< Temperature at point 1 real, intent(in) :: S1 !< Salinity at point 1 - real, intent(in) :: p1_in !< Pressure at point 1 real, intent(in) :: T2 !< Temperature at point 2 real, intent(in) :: S2 !< Salinity at point 2 - real, intent(in) :: p2_in !< Pressure at point 2 real, optional, intent(in) :: drdt1 !< drho_dt at point 1 real, optional, intent(in) :: drds1 !< drho_ds at point 1 real, optional, intent(in) :: drdt2 !< drho_dt at point 2 real, optional, intent(in) :: drds2 !< drho_ds at point 2 + real, optional, intent(in) :: p1_in !< Pressure at point 1 + real, optional, intent(in) :: p2_in !< Pressure at point 2 real :: rho1, rho2, p1, p2, pmid ! Use the same reference pressure or the in-situ pressure @@ -2314,24 +2332,24 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Tests for linearized version of searching the layer for neutral surface position ! EOS linear in T, uniform alpha CS%max_iter = 10 - ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., -0.2, 0., -0.2, 0., & + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., 0., -0.2, 0., 0., -0.2, 0., 10., & (/12.,-4./), (/34.,0./)), "Temp Uniform Linearized Alpha/Beta")) ! EOS linear in S, uniform beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 0.8, 0., 0.8, & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 0., 0.8, 0., 0., 0.8, 10., & (/12.,0./), (/34.,2./)), "Salt Uniform Linearized Alpha/Beta")) ! EOS linear in T/S, uniform alpha/beta - ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., -0.5, 0.5, -0.5, 0.5, -0.5, 0.5, & + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., -0.5, 0.5, 0., -0.5, 0.5, 0., -0.5, 0.5, 10., & (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) - ! EOS linear in T, insensitive to S + ! EOS linear in T, insensitive to ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., -0.4, 0., -0.6, 0., & + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., 0., -0.4, 0., 0., -0.6, 0., 10., & (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) ! EOS linear in S, insensitive to T ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 1.0, 0., 0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 0., 1.0, 0., 0., 0.5, 10., & (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' From 811e225877f1a5c1e26f22c84e7d6a3f90817b6d Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 8 Feb 2019 17:37:38 -0800 Subject: [PATCH 019/259] Add updated unit tests for sorting algorithm --- src/tracer/MOM_neutral_diffusion.F90 | 283 +++++++++++++++++++++++---- 1 file changed, 245 insertions(+), 38 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 23ece3abb1..42ab62843e 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -33,14 +33,14 @@ module MOM_neutral_diffusion !> The control structure for the MOM_neutral_diffusion module type, public :: neutral_diffusion_CS ; private - integer :: nkp1 !< Number of interfaces for a column = nk + 1 - integer :: nsurf !< Number of neutral surfaces - integer :: deg = 2 !< Degree of polynomial used for reconstructions + integer :: nkp1 !< Number of interfaces for a column = nk + 1 + integer :: nsurf !< Number of neutral surfaces + integer :: deg = 2 !< Degree of polynomial used for reconstructions logical :: continuous_reconstruction = .true. !< True if using continuous PPM reconstruction at interfaces logical :: debug = .false. !< If true, write verbose debugging messages integer :: max_iter !< Maximum number of iterations if refine_position is defined - real :: drho_tol!< Convergence criterion representing difference from true neutrality - real :: x_tol !< Convergence criterion for how small an update of the position can be + real :: drho_tol !< Convergence criterion representing difference from true neutrality + real :: x_tol !< Convergence criterion for how small an update of the position can be real :: ref_pres !< Reference pressure, negative if using locally referenced neutral density ! Positions of neutral surfaces in both the u, v directions @@ -208,6 +208,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) allocate(CS%P_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%P_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%dRdP_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%dRdP_i(:,:,:,:) = 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. @@ -310,6 +311,12 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) CS%S_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) endif enddo + do k=1,G%ke + CS%T_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 0. ) + CS%T_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 1. ) + CS%S_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 0. ) + CS%S_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 1. ) + enddo ! Continuous reconstruction if (CS%continuous_reconstruction) then @@ -1038,7 +1045,6 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' end function interpolate_for_nondim_position - !> 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(CS, nk, Pres_l, hcol_l, Tl, Sl, & @@ -1084,6 +1090,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: poly_present ! True if all polynomial coefficients were passed real :: dRho, dRhoTop, dRhoBot, hL, hR real :: z0, pos + real :: dRdT_from_top, dRdS_from_top ! Alpha and beta at the searched from interface + real :: dRdT_from_bot, dRdS_from_bot ! Alpha and beta at the searched from interface + real :: dRdT_to_top, dRdS_to_top ! Alpha and beta at the interfaces being searched + real :: dRdT_to_bot, dRdS_to_bot ! Alpha and beta at the interfaces being searched ! Initialize variables for the search ns = 4*nk @@ -1137,12 +1147,19 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, searching_left_column = .false. searching_right_column = .true. else ! Layers are stable so need to figure out whether we need to search right or left + ! For convenience, the left column uses the searched "from" interface variables, and the right column + ! uses the searched 'to'. These will get reset in subsequent calc_delta_rho calls + + dRdT_from = dRdT_l(kl_left,ki_left) + dRdS_from = dRdS_l(kl_left,ki_left) + dRdT_to_top = dRdT_r(kl_right,ki_right) + dRdS_to_top = dRdS_r(kl_right,ki_right) drho = calc_delta_rho(CS, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), & Tl(kl_left, ki_left), Sl(kl_left, ki_left) , & - dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left, ki_left), & - Pres_r(kl_right, ki_right), Pres_l(kl_left, ki_left)) + dRdT_to_top, dRdS_to_top, & + dRdT_from_top, dRdS_from_top, & + Pres_r(kl_right, ki_right), Pres_l(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 ! Which column has the lighter surface for the current indexes, kr and kl @@ -1167,20 +1184,28 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! Position of the right interface is known PoR(k_surface) = ki_right - 1. KoR(k_surface) = kl_right - + ! For the delta rhoe case wehre density differences are not calculated by displacing the two + ! interfaces to their average pressures, dRdT and dRdS for both columns are the pre-calculated + ! ones + if (TRIM(S%delta_rho_form) == 'no_pressure') then + dRdT_to_top = dRdT_l(kl_left,1); dRdS_to_top = dRdS_l(kl_left,1) + dRdT_to_bot = dRdT_l(kl_left,2); dRdS_to_top = dRdS_l(kl_left,2) + dRdT_from_top = dRdT_r(kl_right,1); dRdS_from_Bot = dRdS_r(kl_right,1) + dRdT_from_bot = dRdT_r(kl_right,2); dRdS_from_Bot = dRdS_r(kl_right,2) + endif ! Calculate difference in density between left top interface and right interface dRhoTop = calc_delta_rho(CS, & Tl(kl_left,1), Sl(kl_left,1), & Tr(kl_right, ki_right), Sr(kl_right, ki_right), & - dRdT_l(kl_left,1), dRdS_l(kl_left,1), & - dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & - Pres_l(kl_left,1), Pres_r(kl_right, ki_right)) + dRdT_to_top, dRdS_to_top, & + dRdT_from_top, dRdS_from_top, & + Pres_l(kl_left,1), Pres_r(kl_right, ki_right)) ! Calculate difference in density between left bottom interface and right interface dRhoBot = calc_delta_rho(CS, & Tl(kl_left,2), Sl(kl_left,2), & Tr(kl_right, ki_right), Sr(kl_right, ki_right), & - dRdT_l(kl_left,2), dRdS_l(kl_left,2), & - dRdT_r(kl_right, ki_right), dRdS_r(kl_right, ki_right), & + dRdT_to_bot, dRdS_to_bot, & + dRdT_from_bot, dRdS_from_bot, & Pres_l(kl_left,2), Pres_r(kl_right, ki_right)) ! search_other_column returns -1 if the surface connects somewhere between the layer @@ -1232,6 +1257,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, dRhoTop = calc_delta_rho(CS, & Tr(kl_right,1), Sr(kl_right,1), & Tl(kl_left,ki_left), Sl(kl_left,ki_left), & + dRdT_r(kl_right,1), dRdS_r(kl_right,1), & dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left), & Pres_r(kl_right,1), Pres_l(kl_left,ki_left)) @@ -1241,7 +1267,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, Tl(kl_left,ki_left), Sl(kl_left,ki_left), & dRdT_r(kl_right,2), dRdS_r(kl_right,2), & dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left), & - Pres_r(kl_right,2), Pres_l(kl_left,ki_left)) + Pres_r(kl_right,2), Pres_l(kl_left,ki_left)) ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) if (pos < 0.) then @@ -1336,7 +1362,11 @@ real function search_other_column(dRhoTop, dRhoBot, ki_other, ksurf ) result(pos elseif ( drhotop < 0. .and. drhobot < 0.) then ! Denser than anything in layer pos = 1. elseif ( drhotop == 0. .and. drhobot == 0. ) then ! Perfectly unstratified - pos = ki_other - 1 + pos = 1. + elseif ( drhobot == 0. ) then + pos = 1. + elseif ( drhotop == 0. ) then + pos = 0. else pos = -1 endif @@ -1401,7 +1431,7 @@ real function neutral_pos(CS, z0, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_re pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) elseif (CS%neutral_pos_method == 2) then pos = find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_ref, dRdT_top, dRdS_top, P_top, & - dRdT_bot, dRdT_bot, P_bot, Tpoly, Spoly ) + dRdT_bot, dRdS_bot, P_bot, Tpoly, Spoly ) elseif (CS%neutral_pos_method == 3) then ! pos = refine_nondim_position(CS, T_ref, S_ref, dRdT_ref, dRdS_ref, P_top, P_bot, & ! Tpoly, Spoly, dRhoTop, dRhoBot, 0.) @@ -1447,7 +1477,7 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_re ! Position independent quantities dRdT_diff = dRdT_bot - dRdT_top - dRdS_diff = dRdS_bot - dRdS_top + dRdS_diff = dRdS_bot - dRdS_top ! Initial starting drho (used for bisection) zmin = z0 ! Lower bounding interval zmax = 1. ! Maximum bounding interval (bottom of layer) @@ -1458,13 +1488,24 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_re dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot P_z = a1*P_top + a2*P_bot - drho_min = calc_delta_rho(CS, T_z, S_z, dRdT_z, dRdS_z, T_ref, S_ref, dRdT_ref, dRdS_ref, P_z, P_ref) + drho_min = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, dRdT_z, dRdS_z, dRdT_ref, dRdS_ref, P_z, P_ref) + T_z = evaluation_polynomial( ppoly_T, nterm, zmax ) S_z = evaluation_polynomial( ppoly_S, nterm, zmax ) - drho_max = calc_delta_rho(CS, T_z, S_z, dRdT_bot, dRdS_bot, T_ref, S_ref, dRdT_ref, dRdS_ref, P_bot, P_ref) + drho_max = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, dRdT_bot, dRdS_bot, dRdT_ref, dRdS_ref, P_bot, P_ref) + + if (drho_min >= 0.) then + z = z0 + return + elseif (drho_max == 0.) then + z = 1. + endif + if ( SIGN(1.,drho_min) == SIGN(1.,drho_max) ) then + call MOM_error(FATAL, "drho_min is the same sign as dhro_max") + endif z = z0 - print *, z, drho_min, drho_max + ztest = z0 do iter = 1, CS%max_iter ! Calculate quantities at the current nondimensional position a1 = 1.-z @@ -1477,14 +1518,10 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_re deltaS = S_z - S_ref dRdT_sum = dRdT_ref + dRdT_z dRdS_sum = dRdS_ref + dRdS_z - drho = calc_delta_rho(CS, T_z, S_z, dRdT_z, dRdS_z, T_ref, S_ref, dRdT_ref, dRdS_ref, P_z, P_ref) - - print *, "Iteration: ", iter - ! Check to make sure that the position at z0 is negative, otherwise the starting position should be returned - if (iter == 1 .and. drho > 0.) exit + drho = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, dRdT_z, dRdS_z, dRdT_ref, dRdS_ref, P_z, P_ref) ! Check for convergence - if (ABS(drho) <= CS%drho_tol) exit + if (ABS(drho) <= CS%drho_tol) exit ! Update bisection bracketing intervals if (drho < 0. .and. drho > drho_min) then drho_min = drho @@ -1493,32 +1530,26 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_re drho_max = drho zmax = z endif - print *, z, zmin, zmax - print *, drho, drho_min, drho_max ! Calculate a Newton step dT_dz = first_derivative_polynomial( ppoly_T, nterm, z ) dS_dz = first_derivative_polynomial( ppoly_S, nterm, z ) drho_dz = 0.5*( (dRdT_diff*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) ) - ztest = z - drho/drho_dz ! Take a bisection if z falls out of [zmin,zmax] if (ztest < zmin .or. ztest > zmax) then - print *, 'Bisection' if ( drho < 0. ) then ztest = 0.5*(z + zmax) else ztest = 0.5*(zmin + z) endif endif - + ! Test to ensure we haven't stalled out if ( abs(z-ztest) <= CS%x_tol ) exit - ! Reset for next iteration z = ztest enddo - pause end function find_neutral_pos_linear @@ -1547,18 +1578,26 @@ real function calc_delta_rho(CS, T1, S1, T2, S2, drdt1, drds1, drdt2, drds2, p1_ endif ! Use the full linear equation of state to calculate the difference in density (expensive!) - if (CS%delta_rho_form == 'full') then + if (TRIM(CS%delta_rho_form) == 'full') then pmid = 0.5 * (p1 + p2) call calculate_density( T1, S1, pmid, rho1, CS%EOS ) call calculate_density( T2, S2, pmid, rho2, CS%EOS ) delta_rho = rho1 - rho2 ! Use alpha and beta (without pressure dependence) - elseif (CS%delta_rho_form == 'no_pressure') then + elseif (TRIM(CS%delta_rho_form) == 'no_pressure') then if (.not. (PRESENT(drdt1) .and. PRESENT(drds1) .and. present(drdt2) .and. present(drds2)) ) then call MOM_error(FATAL,"DELTA_RHO_FORM == linear requires drdt and drds") else delta_rho = 0.5 *( (drdt1+drdt2)*(T1-T2) + (drds1+drds2)*(S1-S2) ) endif + elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then + pmid = 0.5 * (p1 + p2) + if (CS%ref_pres>=0) pmid = CS%ref_pres + call calculate_density_derivs(T1, S1, pmid, CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS) + call + delta_rho = 0.5 *( (drdt1+drdt2)*(T1-T2) + (drds1+drds2)*(S1-S2) ) + else + call MOM_error(FATAL, "delta_rho_form is not recognized") endif end function calc_delta_rho @@ -2301,6 +2340,174 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff 'Unstable mixed layers, left cooler') + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical Columns') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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 + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Right slightly cooler') + + TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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 + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left slightly cooler') + + TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); + TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 0.00, 0.25, 0.50, 0.75, 1.00, 0.00, 0.00, 0.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right more strongly stratified') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Deep Mixed layer on the right') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.25, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical columns with mixed layer') + + TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); + TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Left interior unstratified') + + TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); + TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left mixed layer, Right unstable interior') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 0.75, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Left thick mixed layer, Right unstable mixed') + + TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); + call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Unstable mixed layers, left cooler') + deallocate(remap_CS) ! ! allocate(EOS) @@ -2343,7 +2550,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & find_neutral_pos_linear(CS, 0., 10., 35., -0.5, 0.5, 0., -0.5, 0.5, 0., -0.5, 0.5, 10., & (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) - ! EOS linear in T, insensitive to + ! EOS linear in T, insensitive to ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., 0., -0.4, 0., 0., -0.6, 0., 10., & (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) From 47e8f1c16362bf7fb30443afeb87ed1f7d0beeb8 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Sun, 10 Feb 2019 19:39:42 -0800 Subject: [PATCH 020/259] Start trying to figure out how to add pressure dependence --- src/tracer/MOM_neutral_diffusion.F90 | 115 ++++++++++++++++----------- 1 file changed, 68 insertions(+), 47 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 42ab62843e..655d6103d6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -73,6 +73,7 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressure (Pa) 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 + real, allocatable, dimension(:,:,:,:) :: dRdP_i !< dRho/dp (kg/m3/pascal) 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 => NULL() !< A structure that is used to @@ -250,6 +251,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta + real, dimension(SZI_(G)) :: rho_tmp ! Routiine to calculate drho_dp, returns density which is not used real :: h_neglect, h_neglect_edge real :: pa_to_H @@ -311,6 +313,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) CS%S_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) endif enddo + ! In the current ALE formulation, interface values are not exactly at the 0. or 1. of the + ! polynomial reconstructions do k=1,G%ke CS%T_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 0. ) CS%T_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 1. ) @@ -328,13 +332,19 @@ 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) + ! Calculate derivatives for the top interface 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_compress(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, rho_tmp(:), & + CS%dRdP_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 + ! Calcualte derivatives at the bottom interface 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_compress(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, rho_tmp(:), & + CS%dRdP_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS) enddo endif enddo @@ -366,13 +376,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, & - CS%P_i(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%P_i(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,:,:), & + call find_neutral_surface_positions_discontinuous(CS, G%ke, & + CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%dRdP_i(i,j,:,:), CS%stable_cell(i,j,:), & + CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), & + CS%dRdT_i(i+1,j,:,:), CS%dRdS_i(i+1,j,:,:), CS%dRdP_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 @@ -387,13 +397,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, & - CS%P_i(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%P_i(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,:,:), & + call find_neutral_surface_positions_discontinuous(CS, G%ke, & + CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & + CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%dRdP_i(i,j,:,:), CS%stable_cell(i,j,:), & + CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), & + CS%dRdT_i(i,j+1,:,:), CS%dRdS_i(i,j+1,:,:), CS%dRdP_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 @@ -402,8 +412,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) ! 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... (Please finish this thought. -RWH) + ! calculates hEff from the fraction of the nondimensional fraction of the layer spanned by + ! adjacent neutral surfaces. if (CS%continuous_reconstruction) then 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 @@ -1048,7 +1058,7 @@ end function interpolate_for_nondim_position !> 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(CS, nk, Pres_l, hcol_l, Tl, Sl, & - dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & + dRdT_l, dRdS_l, dRdP_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, dRdP_r, stable_r, & PoL, PoR, KoL, KoR, hEff, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels @@ -1090,10 +1100,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: poly_present ! True if all polynomial coefficients were passed real :: dRho, dRhoTop, dRhoBot, hL, hR real :: z0, pos - real :: dRdT_from_top, dRdS_from_top ! Alpha and beta at the searched from interface - real :: dRdT_from_bot, dRdS_from_bot ! Alpha and beta at the searched from interface - real :: dRdT_to_top, dRdS_to_top ! Alpha and beta at the interfaces being searched - real :: dRdT_to_bot, dRdS_to_bot ! Alpha and beta at the interfaces being searched + real :: dRdT_from_top, dRdS_from_top ! Density derivatives at the searched from interface + real :: dRdT_from_bot, dRdS_from_bot ! Density derivatives at the searched from interface + real :: dRdT_to_top, dRdS_to_top ! Density derivatives at the interfaces being searched + real :: dRdT_to_bot, dRdS_to_bot ! Density derivatives at the interfaces being searched ! Initialize variables for the search ns = 4*nk @@ -1150,15 +1160,17 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! For convenience, the left column uses the searched "from" interface variables, and the right column ! uses the searched 'to'. These will get reset in subsequent calc_delta_rho calls - dRdT_from = dRdT_l(kl_left,ki_left) - dRdS_from = dRdS_l(kl_left,ki_left) - dRdT_to_top = dRdT_r(kl_right,ki_right) - dRdS_to_top = dRdS_r(kl_right,ki_right) + if (TRIM(S%delta_rho_form) == 'no_pressure') then + dRdT_from = dRdT_l(kl_left,ki_left) + dRdS_from = dRdS_l(kl_left,ki_left) + dRdT_to_top = dRdT_r(kl_right,ki_right) + dRdS_to_top = dRdS_r(kl_right,ki_right) + endif drho = calc_delta_rho(CS, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), & Tl(kl_left, ki_left), Sl(kl_left, ki_left) , & dRdT_to_top, dRdS_to_top, & - dRdT_from_top, dRdS_from_top, & + dRdT_from, dRdS_from, & Pres_r(kl_right, ki_right), Pres_l(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 @@ -1188,24 +1200,23 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! interfaces to their average pressures, dRdT and dRdS for both columns are the pre-calculated ! ones if (TRIM(S%delta_rho_form) == 'no_pressure') then - dRdT_to_top = dRdT_l(kl_left,1); dRdS_to_top = dRdS_l(kl_left,1) - dRdT_to_bot = dRdT_l(kl_left,2); dRdS_to_top = dRdS_l(kl_left,2) - dRdT_from_top = dRdT_r(kl_right,1); dRdS_from_Bot = dRdS_r(kl_right,1) - dRdT_from_bot = dRdT_r(kl_right,2); dRdS_from_Bot = dRdS_r(kl_right,2) + dRdT_to_top = dRdT_l(kl_left,1) ; dRdS_to_top = dRdS_l(kl_left,1) + dRdT_to_bot = dRdT_l(kl_left,2) ; dRdS_to_bot = dRdS_l(kl_left,2) + dRdT_from = dRdT_r(kl_right,ki_right) ; dRdS_from = dRdS_r(kl_right,ki_right) endif ! Calculate difference in density between left top interface and right interface dRhoTop = calc_delta_rho(CS, & Tl(kl_left,1), Sl(kl_left,1), & Tr(kl_right, ki_right), Sr(kl_right, ki_right), & dRdT_to_top, dRdS_to_top, & - dRdT_from_top, dRdS_from_top, & + dRdT_from, dRdS_from, & Pres_l(kl_left,1), Pres_r(kl_right, ki_right)) ! Calculate difference in density between left bottom interface and right interface dRhoBot = calc_delta_rho(CS, & Tl(kl_left,2), Sl(kl_left,2), & Tr(kl_right, ki_right), Sr(kl_right, ki_right), & dRdT_to_bot, dRdS_to_bot, & - dRdT_from_bot, dRdS_from_bot, & + dRdT_from, dRdS_from, & Pres_l(kl_left,2), Pres_r(kl_right, ki_right)) ! search_other_column returns -1 if the surface connects somewhere between the layer @@ -1252,21 +1263,28 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! Position of the left interface is known PoL(k_surface) = ki_left - 1. KoL(k_surface) = kl_left + ! For the delta rhoe case wehre density differences are not calculated by displacing the two + ! interfaces to their average pressures, dRdT and dRdS for both columns are the pre-calculated + ! ones + if (TRIM(S%delta_rho_form) == 'no_pressure') then + dRdT_to_top = dRdT_r(kl_right,1); dRdS_to_top = dRdS_r(kl_right,1) + dRdT_to_bot = dRdT_r(kl_right,2); dRdS_to_top = dRdS_r(kl_right,2) + dRdT_from = dRdT_l(kl_left,ki_left); dRdS_from = dRdS_l(kl_left,ki_left) + endif ! Calculate difference in density between left top interface and right interface dRhoTop = calc_delta_rho(CS, & Tr(kl_right,1), Sr(kl_right,1), & Tl(kl_left,ki_left), Sl(kl_left,ki_left), & - - dRdT_r(kl_right,1), dRdS_r(kl_right,1), & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left), & + dRdT_to_top, dRdS_to_top, & + dRdT_from_top, dRdS_from_top, & Pres_r(kl_right,1), Pres_l(kl_left,ki_left)) ! Calculate difference in density between left bottom interface and right interface dRhoBot = calc_delta_rho(CS, & Tr(kl_right,2), Sr(kl_right,2), & Tl(kl_left,ki_left), Sl(kl_left,ki_left), & - dRdT_r(kl_right,2), dRdS_r(kl_right,2), & - dRdT_l(kl_left, ki_left), dRdS_l(kl_left,ki_left), & + dRdT_to_bot, dRdS_to_bot, & + dRdT_from_bot, dRdS_from_bot, & Pres_r(kl_right,2), Pres_l(kl_left,ki_left)) ! search_other_column returns -1 if the surface connects somewhere between the layer pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) @@ -1441,13 +1459,16 @@ real function neutral_pos(CS, z0, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_re end function neutral_pos !> Search a layer to find where delta_rho = 0 based on a linear interpolation of alpha and beta of the top and bottom -!! being searched and polynomial reconstructions of T and S. We need Newton's method because the T and S -!! reconstructions make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search -!! fall out of the interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta -!! means that second derivatives of the EOS are not needed. Note that delta in variable names below refers to -!! horizontal differences and 'd' refers to vertical differences -function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_ref, dRdT_top, dRdS_top, & - P_top, dRdT_bot, dRdS_bot, P_bot, ppoly_T, ppoly_S ) result( z ) +!! being searched and polynomial reconstructions of T and S. Compressibility is not needed because either, we are +!! assuming incompressibility in the equation of state for this module or alpha and beta are calculated having been +!! displaced to the average pressures of the two pressures We need Newton's method because the T and S reconstructions +!! make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search fall out of the +!! interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta means that second +!! derivatives of the EOS are not needed. Note that delta in variable names below refers to horizontal differences and +!! 'd' refers to vertical differences +function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdP_ref, P_ref, & + dRdT_top, dRdS_top, dRdP_top, P_top, & + dRdT_bot, dRdS_bot, dRdP_bot, P_bot, ppoly_T, ppoly_S ) result( z ) type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess real, intent(in) :: T_ref !< Temperature at the searched from interface @@ -1488,7 +1509,8 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_re dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot P_z = a1*P_top + a2*P_bot - drho_min = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, dRdT_z, dRdS_z, dRdT_ref, dRdS_ref, P_z, P_ref) + drho_min = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, & + dRdT_z, dRdS_z, dRdT_ref, dRdS_ref, dRdP_z, dRdP_ref, P_z, P_ref) T_z = evaluation_polynomial( ppoly_T, nterm, zmax ) S_z = evaluation_polynomial( ppoly_S, nterm, zmax ) @@ -1593,8 +1615,7 @@ real function calc_delta_rho(CS, T1, S1, T2, S2, drdt1, drds1, drdt2, drds2, p1_ elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then pmid = 0.5 * (p1 + p2) if (CS%ref_pres>=0) pmid = CS%ref_pres - call calculate_density_derivs(T1, S1, pmid, CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS) - call + call calculate_density_derivs(T1, S1, pmid, CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS) delta_rho = 0.5 *( (drdt1+drdt2)*(T1-T2) + (drds1+drds2)*(S1-S2) ) else call MOM_error(FATAL, "delta_rho_form is not recognized") From f054221d8c4a4caaa55b9d1be02c43b3b4dc6d6b Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 18 Feb 2019 18:21:43 -0800 Subject: [PATCH 021/259] Major refactor for neutral diffusion To reduce the likelihood of making errors when searching left or right, much of the redundant code was refactored and put into search_other_column. Other improvements: - Add a method that calculates the difference in density based on the full equation of state - Add a runtime option RECALC_NEUTRAL_SURF if neutral surfaces should be recalculated if diagnosed KHTR is higher than CFL would allow --- src/equation_of_state/MOM_EOS.F90 | 29 +- src/tracer/MOM_neutral_diffusion.F90 | 1159 ++++++++++++-------------- src/tracer/MOM_tracer_hor_diff.F90 | 9 + 3 files changed, 547 insertions(+), 650 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 9a823d23eb..38cd93a210 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -77,6 +77,10 @@ module MOM_EOS module procedure calculate_TFreeze_scalar, calculate_TFreeze_array end interface calculate_TFreeze +interface calculate_compress + module procedure calculate_compress_scalar, calculate_compress_array +end interface calculate_compress + !> A control structure for the equation of state type, public :: EOS_type ; private integer :: form_of_EOS = 0 !< The equation of state to use. @@ -508,7 +512,7 @@ subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, end subroutine calculate_specific_vol_derivs !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. -subroutine calculate_compress(T, S, pressure, rho, drho_dp, start, npts, EOS) +subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, EOS) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) real, dimension(:), intent(in) :: S !< Salinity (PSU) real, dimension(:), intent(in) :: pressure !< Pressure (Pa) @@ -539,8 +543,29 @@ subroutine calculate_compress(T, S, pressure, rho, drho_dp, start, npts, EOS) "calculate_compress: EOS%form_of_EOS is not valid.") end select -end subroutine calculate_compress +end subroutine calculate_compress_array + +!> Calculate density and compressibility for a scalar. This just promotes the scalar to an array with a singleton +!! dimension and calls calculate_compress_array +subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) + real, intent(in) :: T !< Potential temperature referenced to the surface (degC) + real, intent(in) :: S !< Salinity (PSU) + real, intent(in) :: pressure !< Pressure (Pa) + real, intent(out) :: rho !< In situ density in kg m-3. + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) in s2 m-2. + type(EOS_type), pointer :: EOS !< Equation of state structure + + real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_compress called with an unassociated EOS_type EOS.") + Ta(1) = T ; Sa(1) = S; pa(1) = pressure + + call calculate_compress_array(Ta, Sa, pa, rhoa, drho_dpa, 1, 1, EOS) + rho = rhoa(1) ; drho_dp = drho_dpa(1) +end subroutine calculate_compress_scalar !> Calls the appropriate subroutine to alculate analytical and nearly-analytical !! integrals in pressure across layers of geopotential anomalies, which are !! required for calculating the finite-volume form pressure accelerations in a diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 655d6103d6..eb18b88f4a 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -163,7 +163,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) "3. Keep recalculating alpha and beta (no pressure \n"// & " dependence) Newton's method for neutral position \n"// & "4. Full nonlinear equation of state, Brent's method \n"// & - " for neutral position", default=1) + " for neutral position", default=2) if (CS%neutral_pos_method > 4 .or. CS%neutral_pos_method < 0) then call MOM_error(FATAL,"Invalid option for NEUTRAL_POS_METHOD") endif @@ -173,7 +173,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) " full : Difference of in-situ densities \n"// & " no_pressure: Calculated from dRdT, dRdS, but no \n"// & " pressure dependence", & - default="no_pressure") + default="mid_pressure") if (CS%neutral_pos_method > 1) then call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & "Sets the convergence criterion for finding the neutral\n"// & @@ -313,7 +313,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) CS%S_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) endif enddo - ! In the current ALE formulation, interface values are not exactly at the 0. or 1. of the + ! In the current ALE formulation, interface values are not exactly at the 0. or 1. of the ! polynomial reconstructions do k=1,G%ke CS%T_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 0. ) @@ -351,9 +351,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) if (.not. CS%continuous_reconstruction) then do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 - call mark_unstable_cells( CS, G%ke, CS%dRdT_i(i,j,:,:), CS%dRdS_i(i,j,:,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), & - CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) - enddo ; enddo + call mark_unstable_cells( CS, G%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) + enddo ; enddo endif CS%uhEff(:,:,:) = 0. @@ -376,14 +375,12 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, & - CS%P_i(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%dRdP_i(i,j,:,:), CS%stable_cell(i,j,:), & - CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), & - CS%dRdT_i(i+1,j,:,:), CS%dRdS_i(i+1,j,:,:), CS%dRdP_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,:,:)) + call find_neutral_surface_positions_discontinuous(CS, G%ke, & + CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & + CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & + CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%ppoly_coeffs_T(i+1,j,:,:), & + CS%ppoly_coeffs_S(i+1,j,:,:), CS%stable_cell(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:)) endif endif enddo ; enddo @@ -397,15 +394,12 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, 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(CS, G%ke, & - CS%P_i(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%dRdP_i(i,j,:,:), CS%stable_cell(i,j,:), & - CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), & - CS%dRdT_i(i,j+1,:,:), CS%dRdS_i(i,j+1,:,:), CS%dRdP_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,:,:)) - + call find_neutral_surface_positions_discontinuous(CS, G%ke, & + CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & + CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & + CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%ppoly_coeffs_T(i,j+1,:,:), & + CS%ppoly_coeffs_S(i,j+1,:,:), CS%stable_cell(i,j+1,:), & + CS%vPoL(I,j,:), CS%vPoR(I,j,:), CS%vKoL(I,j,:), CS%vKoR(I,j,:), CS%vhEff(I,j,:)) endif endif enddo ; enddo @@ -1056,25 +1050,27 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) end function interpolate_for_nondim_position !> 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(CS, nk, Pres_l, hcol_l, Tl, Sl, & - dRdT_l, dRdS_l, dRdP_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, dRdP_r, stable_r, & - PoL, PoR, KoL, KoR, hEff, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r) +!! of combined interfaces using intracell reconstructions of T/S. Note that the polynomial reconstrcutions +!! of T and S are optional to aid with unit testing, but will always be passed otherwise +subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l,& + Pres_r, hcol_r, Tr, Sr, ppoly_T_r, ppoly_S_r, stable_r,& + PoL, PoR, KoL, KoR, hEff) + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels real, dimension(nk,2), 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) + real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction + real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction logical, dimension(nk), intent(in) :: stable_l !< Left-column, top interface dRho/dS (kg/m3/ppt) real, dimension(nk,2), 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) - real, dimension(nk,2), intent(in) :: dRdS_r !< Right-column, top interface dRho/dS (kg/m3/ppt) + real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction + real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction 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 @@ -1083,10 +1079,6 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, integer, dimension(4*nk), intent(inout) :: KoL !< Index of first left interface above neutral surface integer, dimension(4*nk), intent(inout) :: KoR !< Index of first right interface above neutral surface real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) - real, dimension(:,:), optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction - real, dimension(:,:), optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction - real, dimension(:,:), optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction - real, dimension(:,:), optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction ! Local variables integer :: ns ! Number of neutral surfaces @@ -1097,13 +1089,14 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target logical :: search_layer - logical :: poly_present ! True if all polynomial coefficients were passed real :: dRho, dRhoTop, dRhoBot, hL, hR real :: z0, pos - real :: dRdT_from_top, dRdS_from_top ! Density derivatives at the searched from interface - real :: dRdT_from_bot, dRdS_from_bot ! Density derivatives at the searched from interface - real :: dRdT_to_top, dRdS_to_top ! Density derivatives at the interfaces being searched - real :: dRdT_to_bot, dRdS_to_bot ! Density derivatives at the interfaces being searched + real :: dRdT_from_top, dRdS_from_top, dRdP_from_top ! Density derivatives at the searched from interface + real :: dRdT_from_bot, dRdS_from_bot, dRdP_from_bot ! Density derivatives at the searched from interface + real :: dRdT_to_top, dRdS_to_top, dRdP_to_top ! Density derivatives at the interfaces being searched + real :: dRdT_to_bot, dRdS_to_bot, dRdP_to_bot ! Density derivatives at the interfaces being searched + real :: T_ref, S_ref, P_ref, P_top, P_bot + real :: lastP_left, lastP_right ! Initialize variables for the search ns = 4*nk @@ -1111,11 +1104,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ki_left = 1 kl_left = 1 kl_right = 1 + lastP_left = 0. + lastP_right = 0. reached_bottom = .false. searching_left_column = .false. searching_right_column = .false. - ! Check if polynomials are present - poly_present = PRESENT( ppoly_T_l ) .and. PRESENT( ppoly_S_l ) .and. PRESENT( ppoly_T_r ) .and. PRESENT( ppoly_S_r) ! Loop over each neutral surface, working from top to bottom neutral_surfaces: do k_surface = 1, ns @@ -1160,18 +1153,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! For convenience, the left column uses the searched "from" interface variables, and the right column ! uses the searched 'to'. These will get reset in subsequent calc_delta_rho calls - if (TRIM(S%delta_rho_form) == 'no_pressure') then - dRdT_from = dRdT_l(kl_left,ki_left) - dRdS_from = dRdS_l(kl_left,ki_left) - dRdT_to_top = dRdT_r(kl_right,ki_right) - dRdS_to_top = dRdS_r(kl_right,ki_right) - endif - drho = calc_delta_rho(CS, & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), & - Tl(kl_left, ki_left), Sl(kl_left, ki_left) , & - dRdT_to_top, dRdS_to_top, & - dRdT_from, dRdS_from, & - Pres_r(kl_right, ki_right), Pres_l(kl_left, ki_left)) + call calc_delta_rho_and_derivs(CS, & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & + Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & + 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 @@ -1193,136 +1178,50 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, endif endif if (searching_left_column) then - ! Position of the right interface is known + ! Position of the right interface is known and all quantities are fixed PoR(k_surface) = ki_right - 1. KoR(k_surface) = kl_right - ! For the delta rhoe case wehre density differences are not calculated by displacing the two - ! interfaces to their average pressures, dRdT and dRdS for both columns are the pre-calculated - ! ones - if (TRIM(S%delta_rho_form) == 'no_pressure') then - dRdT_to_top = dRdT_l(kl_left,1) ; dRdS_to_top = dRdS_l(kl_left,1) - dRdT_to_bot = dRdT_l(kl_left,2) ; dRdS_to_bot = dRdS_l(kl_left,2) - dRdT_from = dRdT_r(kl_right,ki_right) ; dRdS_from = dRdS_r(kl_right,ki_right) - endif - ! Calculate difference in density between left top interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tl(kl_left,1), Sl(kl_left,1), & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), & - dRdT_to_top, dRdS_to_top, & - dRdT_from, dRdS_from, & - Pres_l(kl_left,1), Pres_r(kl_right, ki_right)) - ! Calculate difference in density between left bottom interface and right interface - dRhoBot = calc_delta_rho(CS, & - Tl(kl_left,2), Sl(kl_left,2), & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), & - dRdT_to_bot, dRdS_to_bot, & - dRdT_from, dRdS_from, & - Pres_l(kl_left,2), Pres_r(kl_right, ki_right)) - - ! search_other_column returns -1 if the surface connects somewhere between the layer - pos = search_other_column(dRhoTop, dRhoBot, ki_right, k_surface) - if (pos < 0.) then - if (kl_left == KoL(k_surface-1)) then - z0 = PoL(k_surface-1) - else - z0 = 0. - endif - if (poly_present) then - ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments - pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & - Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& - dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & - Pres_l(kl_left,1), Pres_l(kl_left,2), & - dRdT_l(kl_left,1), dRdS_l(kl_left,1), & - dRdT_l(kl_left,2), dRdS_l(kl_left,2), & - ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:) ) - else - pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & - Tr(kl_right,ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right),& - dRdT_r(kl_right,ki_right), dRdS_r(kl_right,ki_right), & - Pres_l(kl_left,1), Pres_l(kl_left,2), & - dRdT_l(kl_left,1), dRdS_l(kl_left,1), & - dRdT_l(kl_left,2), dRdS_l(kl_left,2) ) - endif - endif - - PoL(k_surface) = pos + PoL(k_surface) = search_other_column(CS, k_surface, lastP_left, & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & + Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & + Tl(kl_left,2), Sl(kl_left,2), Pres_l(kl_left,2), & + ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:)) KoL(k_surface) = kl_left 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)') "Searching left layer ", kl_left 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) write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) endif call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) + lastP_left = PoL(k_surface) + ! If the right layer increments, then we need to reset the last position on the right + if ( kl_right == (KoR(k_surface) + 1) ) lastP_right = 0. elseif (searching_right_column) then - ! Position of the left interface is known + ! Position of the right interface is known and all quantities are fixed PoL(k_surface) = ki_left - 1. KoL(k_surface) = kl_left - ! For the delta rhoe case wehre density differences are not calculated by displacing the two - ! interfaces to their average pressures, dRdT and dRdS for both columns are the pre-calculated - ! ones - if (TRIM(S%delta_rho_form) == 'no_pressure') then - dRdT_to_top = dRdT_r(kl_right,1); dRdS_to_top = dRdS_r(kl_right,1) - dRdT_to_bot = dRdT_r(kl_right,2); dRdS_to_top = dRdS_r(kl_right,2) - dRdT_from = dRdT_l(kl_left,ki_left); dRdS_from = dRdS_l(kl_left,ki_left) - endif + PoR(k_surface) = search_other_column(CS, k_surface, lastP_right, & + Tl(kl_left, ki_left), Sl(kl_left, ki_left), Pres_l(kl_left, ki_left), & + Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & + Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & + ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:)) + KoR(k_surface) = kl_right - ! Calculate difference in density between left top interface and right interface - dRhoTop = calc_delta_rho(CS, & - Tr(kl_right,1), Sr(kl_right,1), & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), & - dRdT_to_top, dRdS_to_top, & - dRdT_from_top, dRdS_from_top, & - Pres_r(kl_right,1), Pres_l(kl_left,ki_left)) - ! Calculate difference in density between left bottom interface and right interface - dRhoBot = calc_delta_rho(CS, & - Tr(kl_right,2), Sr(kl_right,2), & - Tl(kl_left,ki_left), Sl(kl_left,ki_left), & - dRdT_to_bot, dRdS_to_bot, & - dRdT_from_bot, dRdS_from_bot, & - Pres_r(kl_right,2), Pres_l(kl_left,ki_left)) - ! search_other_column returns -1 if the surface connects somewhere between the layer - pos = search_other_column(dRhoTop, dRhoBot, ki_left, k_surface) - if (pos < 0.) then - if (kl_right == KoR(k_surface-1)) then - z0 = PoR(k_surface-1) - else - z0 = 0. - endif - ! Note: we do a test to ensure that polynomials were passed to avoid problems with optional arguments - if (poly_present) then - pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & - Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & - dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & - Pres_r(kl_right,1), Pres_r(kl_right,2), & - dRdT_r(kl_right,1), dRdS_r(kl_right,1), & - dRdT_r(kl_right,2), dRdS_r(kl_right,2), & - ppoly_T_r(kl_right,:), ppoly_S_r(kl_right,:) ) - else - pos = neutral_pos(CS, z0, dRhoTop, dRhoBot, & - Tl(kl_left,ki_left), Sl(kl_left, ki_left), Pres_l(kl_left,ki_left), & - dRdT_l(kl_left,ki_left), dRdS_l(kl_left,ki_left), & - Pres_r(kl_right,1), Pres_r(kl_right,2), & - dRdT_r(kl_right,1), dRdS_r(kl_right,1), & - dRdT_r(kl_right,2), dRdS_r(kl_right,2) ) - endif - endif - PoR(k_surface) = pos - KoR(k_surface) = Kl_right 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 - write(*,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) - write(*,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) - write(*,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) + write(*,'(A,I2)') "Searching left layer ", kl_left + 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) + write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) endif call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) + lastP_right = PoR(k_surface) + ! If the right layer increments, then we need to reset the last position on the right + if ( kl_left == (KoL(k_surface) + 1) ) lastP_left = 0. else stop 'Else what?' endif @@ -1347,11 +1246,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, end subroutine find_neutral_surface_positions_discontinuous !> Sweep down through the column and mark as stable if the bottom interface of a cell is denser than the top -subroutine mark_unstable_cells(CS, nk, dRdT, dRdS, T, S, P, stable_cell) +subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels in a column - 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 !< Temperature at interfaces real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces @@ -1361,34 +1258,78 @@ subroutine mark_unstable_cells(CS, nk, dRdT, dRdS, T, S, P, stable_cell) real :: delta_rho do k = 1,nk - stable_cell(k) = ( calc_delta_rho(CS, T(k,2), S(k,2), T(k,1), S(k,1), & - dRdT(k,2), dRdS(k,2), dRdT(k,1), dRdS(k,2), P(k,2), P(k,1)) > 0. ) + call calc_delta_rho_and_derivs( CS, T(k,2), S(k,2), P(k,2), T(k,1), S(k,1), P(k,1), delta_rho ) + stable_cell(k) = delta_rho > 0. enddo end subroutine mark_unstable_cells !> Searches the "other" (searched) column for the position of the neutral surface -real function search_other_column(dRhoTop, dRhoBot, ki_other, ksurf ) result(pos) - real, intent(in ) :: dRhoTop !< Density difference across top interface - real, intent(in ) :: dRhoBot !< Density difference across top interface - integer, intent(in ) :: ki_other !< Index of interface being searched from - integer, intent(in ) :: ksurf !< Current index of neutral surface +real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T_top, S_top, P_top, & + T_bot, S_bot, P_bot, T_poly, S_poly ) result(pos) + type(neutral_diffusion_CS), intent(in ) :: CS !< Neutral diffusion control structure + integer, intent(in ) :: ksurf !< Current index of neutral surface + real, intent(in ) :: pos_last !< Last position within the current layer, used as the lower + !! bound in the rootfinding algorithm + real, intent(in ) :: T_from !< Temperature at the searched from interface + real, intent(in ) :: S_from !< Salinity at the searched from interface + real, intent(in ) :: P_from !< Pressure at the searched from interface + real, intent(in ) :: T_top !< Temperature at the searched to top interface + real, intent(in ) :: S_top !< Salinity at the searched to top interface + real, intent(in ) :: P_top !< Pressure at the searched to top interface + real, intent(in ) :: T_bot !< Temperature at the searched to bottom interface + real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface + real, intent(in ) :: P_bot !< Pressure at the searched to bottom interface + real, dimension(:), intent(in ) :: T_poly !< Temperature polynomial reconstruction coefficients + real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction coefficients + ! Local variables + real :: dRhotop, dRhobot + real :: dRdT_top, dRdS_top, dRdP_top, dRdT_bot, dRdS_bot, dRdP_bot + real :: dRdT_from, dRdS_from, dRdP_from + real :: P_mid + + ! Calculate the differencei in density at the tops or the bottom + if (CS%neutral_pos_method == 1 .or. CS%neutral_pos_method == 3) then + call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop) + call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) + elseif (CS%neutral_pos_method == 2) then + call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop, & + dRdT_top, dRdS_top, dRdP_top, dRdT_from, dRdS_from, dRdP_from) + call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot, & + dRdT_bot, dRdS_bot, dRdP_bot, dRdT_from, dRdS_from, dRdP_from) + endif - if ( (drhotop > 0.) .or. (ksurf == 1) ) then ! First interface or lighter than anything in layer + ! Handle all the special cases EXCEPT if it connects within the layer + if ( (dRhoTop > 0.) .or. (ksurf == 1) ) then ! First interface or lighter than anything in layer pos = 0. - elseif ( drhotop > drhobot ) then ! Unstably stratified + elseif ( dRhoTop > dRhoBot ) then ! Unstably stratified pos = 1. - elseif ( drhotop < 0. .and. drhobot < 0.) then ! Denser than anything in layer + elseif ( dRhoTop < 0. .and. dRhoBot < 0.) then ! Denser than anything in layer pos = 1. - elseif ( drhotop == 0. .and. drhobot == 0. ) then ! Perfectly unstratified + elseif ( dRhoTop == 0. .and. dRhoBot == 0. ) then ! Perfectly unstratified pos = 1. - elseif ( drhobot == 0. ) then + elseif ( dRhoBot == 0. ) then ! Matches perfectly at the Top pos = 1. - elseif ( drhotop == 0. ) then + elseif ( dRhoTop == 0. ) then ! Matches perfectly at the Bottom pos = 0. - else + else ! Neutral surface within layer pos = -1 endif + ! Can safely return if position is >= 0 otherwise will need to find the position within the layer + if (pos>=0) return + + if (CS%neutral_pos_method==1) then + pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) + ! For the 'Linear' case of finding the neutral position, the fromerence pressure to use is the average + ! of the midpoint of the layer being searched and the interface being searched from + elseif (CS%neutral_pos_method == 2) then + pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, P_from, dRdT_from, dRdS_from, dRdP_from, & + P_top, dRdT_top, dRdS_top, dRdP_top, & + P_bot, dRdT_bot, dRdS_bot, dRdP_bot, T_poly, S_poly ) + elseif (CS%neutral_pos_method == 3) then + pos = find_neutral_pos_full( CS, pos_last, T_from, S_from, P_from, P_top, P_bot, T_poly, S_poly) + endif + end function search_other_column !> Increments the interface which was just connected and also set flags if the bottom is reached @@ -1418,57 +1359,17 @@ subroutine increment_interface(nk, kl, ki, reached_bottom, searching_this_column endif end subroutine increment_interface -!> Use some form of interpolation or rootfinding to find the position of a neutral surface within the layer -!! In order of increasing accuracy -!! 1. Delta_rho varies linearly, find 0 crossing -!! 2. Alpha and beta vary linearly from top to bottom, rootfinding for 0. position -!! 3. Keep recalculating alpha and beta (no pressure dependence), rootfinding for 0. position -!! 4. Full nonlinear equation of state -real function neutral_pos(CS, z0, dRhoTop, dRhoBot, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & - P_top, P_bot, dRdT_top, dRdS_top, dRdT_bot, dRdS_bot, Tpoly, Spoly ) & - result(pos) - type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure - real, optional :: z0 !< Initial guess (0. or previous pos) - real, optional :: dRhoTop !< delta rho at top interface - real, optional :: dRhoBot !< delta rho at bottom interface - real, optional :: T_ref !< Temperature of other interface - real, optional :: S_ref !< Salinity of other interface - real, optional :: P_ref !< Pressure of other interface - real, optional :: dRdT_ref !< drho/dT of other interface - real, optional :: dRdS_ref !< drho/dS of other interface - real, optional :: P_top !< Pressure at top interface - real, optional :: P_bot !< Pressure at bottom interface - real, optional :: dRdT_top !< drho/dT at cell's top interface - real, optional :: dRdS_top !< drho/dS at cell's top interface - real, optional :: dRdT_bot !< drho/dT at cell's bottom interface - real, optional :: dRdS_bot !< drho/dS at cell's bottom interface - real, optional, dimension(:) :: Tpoly !< Temperature polynomial reconstruction - real, optional, dimension(:) :: Spoly !< Salinity polynomial reconstruction - - if (CS%neutral_pos_method == 1) then - pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) - elseif (CS%neutral_pos_method == 2) then - pos = find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, P_ref, dRdT_top, dRdS_top, P_top, & - dRdT_bot, dRdS_bot, P_bot, Tpoly, Spoly ) - elseif (CS%neutral_pos_method == 3) then -! pos = refine_nondim_position(CS, T_ref, S_ref, dRdT_ref, dRdS_ref, P_top, P_bot, & -! Tpoly, Spoly, dRhoTop, dRhoBot, 0.) - else - call MOM_error(FATAL, "Invalid choice for neutral_pos_method") - endif -end function neutral_pos - !> Search a layer to find where delta_rho = 0 based on a linear interpolation of alpha and beta of the top and bottom -!! being searched and polynomial reconstructions of T and S. Compressibility is not needed because either, we are -!! assuming incompressibility in the equation of state for this module or alpha and beta are calculated having been +!! being searched and polynomial reconstructions of T and S. Compressibility is not needed because either, we are +!! assuming incompressibility in the equation of state for this module or alpha and beta are calculated having been !! displaced to the average pressures of the two pressures We need Newton's method because the T and S reconstructions -!! make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search fall out of the -!! interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta means that second +!! make delta_rho a polynomial function of z if using PPM or higher. If Newton's method would search fall out of the +!! interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta means that second !! derivatives of the EOS are not needed. Note that delta in variable names below refers to horizontal differences and !! 'd' refers to vertical differences -function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdP_ref, P_ref, & - dRdT_top, dRdS_top, dRdP_top, P_top, & - dRdT_bot, dRdS_bot, dRdP_bot, P_bot, ppoly_T, ppoly_S ) result( z ) +function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref, & + P_top, dRdT_top, dRdS_top, dRdP_top, & + P_bot, dRdT_bot, dRdS_bot, dRdP_bot, ppoly_T, ppoly_S ) result( z ) type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess real, intent(in) :: T_ref !< Temperature at the searched from interface @@ -1476,29 +1377,37 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdP real, intent(in) :: P_ref !< Pressure at the searched from interface real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface + real, intent(in) :: dRdP_ref !< dRho/dP at the searched from interface + real, intent(in) :: P_top !< Pressure at top of layer being searched real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched - real, intent(in) :: P_top !< Pressure at top of layer being searched + real, intent(in) :: dRdP_top !< dRho/dP at top of layer being searched + real, intent(in) :: P_bot !< Pressure at bottom of layer being searched real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched - real, intent(in) :: P_bot !< Pressure at bottom of layer being searched + real, intent(in) :: dRdP_bot !< dRho/dP at bottom of layer being searched real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within !! the layer to be searched. real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within !! the layer to be searched. real :: z !< Position where drho = 0 ! Local variables - real :: dRdT_diff, dRdS_diff, drho, drho_dz, dRdT_z, dRdS_z, T_z, S_z, deltaT, deltaS, dT_dz, dS_dz - real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dz, P_z + real :: dRdT_diff, dRdS_diff, dRdP_diff, dRdP_z + real :: drho, drho_dz, dRdT_z, dRdS_z, T_z, S_z, deltaT, deltaS, deltaP, dT_dz, dS_dz + real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dRdP_sum, dz, P_z, dP_dz real :: a1, a2 integer :: iter integer :: nterm + real :: T_top, T_bot, S_top, S_bot nterm = SIZE(ppoly_T) ! Position independent quantities dRdT_diff = dRdT_bot - dRdT_top dRdS_diff = dRdS_bot - dRdS_top + dRdP_diff = dRdP_bot - dRdP_top + ! Assume a linear increase in pressure from top and bottom of the cell + dP_dz = P_bot - P_top ! Initial starting drho (used for bisection) zmin = z0 ! Lower bounding interval zmax = 1. ! Maximum bounding interval (bottom of layer) @@ -1508,19 +1417,22 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdP S_z = evaluation_polynomial( ppoly_S, nterm, zmin ) dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot + dRdP_z = a1*dRdP_top + a2*dRdP_bot P_z = a1*P_top + a2*P_bot - drho_min = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, & - dRdT_z, dRdS_z, dRdT_ref, dRdS_ref, dRdP_z, dRdP_ref, P_z, P_ref) + drho_min = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, dRdP_z, & + T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref) - T_z = evaluation_polynomial( ppoly_T, nterm, zmax ) - S_z = evaluation_polynomial( ppoly_S, nterm, zmax ) - drho_max = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, dRdT_bot, dRdS_bot, dRdT_ref, dRdS_ref, P_bot, P_ref) + T_z = evaluation_polynomial( ppoly_T, nterm, 1. ) + S_z = evaluation_polynomial( ppoly_S, nterm, 1. ) + drho_max = delta_rho_from_derivs(T_z, S_z, P_bot, dRdT_bot, dRdS_bot, dRdP_bot, & + T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref) if (drho_min >= 0.) then z = z0 return elseif (drho_max == 0.) then z = 1. + return endif if ( SIGN(1.,drho_min) == SIGN(1.,drho_max) ) then call MOM_error(FATAL, "drho_min is the same sign as dhro_max") @@ -1534,13 +1446,18 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdP a2 = z dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot + dRdP_z = a1*dRdP_top + a2*dRdP_bot T_z = evaluation_polynomial( ppoly_T, nterm, z ) S_z = evaluation_polynomial( ppoly_S, nterm, z ) + P_z = a1*P_top + a2*P_bot deltaT = T_z - T_ref deltaS = S_z - S_ref + deltaP = P_z - P_ref dRdT_sum = dRdT_ref + dRdT_z dRdS_sum = dRdS_ref + dRdS_z - drho = calc_delta_rho(CS, T_z, S_z, T_ref, S_ref, dRdT_z, dRdS_z, dRdT_ref, dRdS_ref, P_z, P_ref) + dRdP_sum = dRdP_ref + dRdP_z + drho = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, dRdP_z, & + T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref) ! Check for convergence if (ABS(drho) <= CS%drho_tol) exit @@ -1556,8 +1473,10 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdP ! Calculate a Newton step dT_dz = first_derivative_polynomial( ppoly_T, nterm, z ) dS_dz = first_derivative_polynomial( ppoly_S, nterm, z ) - drho_dz = 0.5*( (dRdT_diff*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) ) + drho_dz = 0.5*( (dRdT_diff*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) + & + (dRdP_diff*deltaP + dRdP_sum*dP_dz) ) ztest = z - drho/drho_dz + ! Take a bisection if z falls out of [zmin,zmax] if (ztest < zmin .or. ztest > zmax) then if ( drho < 0. ) then @@ -1575,20 +1494,115 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, dRdP end function find_neutral_pos_linear +!> Use the full equation of state to calculate the difference in locally referenced potential density. The derivatives +!! in this case are not trivial to calculate, so instead we use a regula falsi method +function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly_T, ppoly_S ) result( z ) + type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module + real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess + real, intent(in) :: T_ref !< Temperature at the searched from interface + real, intent(in) :: S_ref !< Salinity at the searched from interface + real, intent(in) :: P_ref !< Pressure at the searched from interface + real, intent(in) :: P_top !< Pressure at top of layer being searched + real, intent(in) :: P_bot !< Pressure at bottom of layer being searched + real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within + !! the layer to be searched. + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within + !! the layer to be searched. + real :: z !< Position where drho = 0 + ! Local variables + integer :: iter + integer :: nterm + + real :: drho_a, drho_b, drho_c + real :: a, b, c, Ta, Tb, Tc, Sa, Sb, Sc, Pa, Pb, Pc + integer :: side + + side = 0 + ! Set the first two evaluation to the endpoints of the interval + b = z0; c = 1 + nterm = SIZE(ppoly_T) + + ! Calculate drho at the minimum bound + Tb = evaluation_polynomial( ppoly_T, nterm, b ) + Sb = evaluation_polynomial( ppoly_S, nterm, b ) + Pb = P_top*(1.-b) + P_bot*b + call calc_delta_rho_and_derivs(CS, Tb, Sb, Pb, T_ref, S_ref, P_ref, drho_b) + + ! Calculate drho at the maximum bound + Tc = evaluation_polynomial( ppoly_T, nterm, 1. ) + Sc = evaluation_polynomial( ppoly_S, nterm, 1. ) + Pc = P_Bot + call calc_delta_rho_and_derivs(CS, Tc, Sc, Pc, T_ref, S_ref, P_ref, drho_c) + + if (drho_b >= 0.) then + z = z0 + return + elseif (drho_c == 0.) then + z = 1. + return + endif + if ( SIGN(1.,drho_b) == SIGN(1.,drho_c) ) then + call MOM_error(FATAL, "drho_min is the same sign as dhro_max") + endif + + do iter = 1, CS%max_iter + ! Calculate new position and evaluate if we have converged + a = (drho_b*c - drho_c*b)/(drho_b-drho_c) + Ta = evaluation_polynomial( ppoly_T, nterm, a ) + Sa = evaluation_polynomial( ppoly_S, nterm, a ) + Pa = P_top*(1.-a) + P_bot*a + call calc_delta_rho_and_derivs(CS, Ta, Sa, Pa, T_ref, S_ref, P_ref, drho_a) + if (ABS(drho_a) < CS%drho_tol) then + z = a + return + endif + + if (drho_a*drho_c > 0.) then + if ( ABS(a-c) 0 ) then + if ( ABS(a-b) Calculate the difference in density between two points in a variety of ways -real function calc_delta_rho(CS, T1, S1, T2, S2, drdt1, drds1, drdt2, drds2, p1_in, p2_in ) result(delta_rho) - type(neutral_diffusion_CS), intent(in) :: CS !< Neutral diffusion control structure - real, intent(in) :: T1 !< Temperature at point 1 - real, intent(in) :: S1 !< Salinity at point 1 - real, intent(in) :: T2 !< Temperature at point 2 - real, intent(in) :: S2 !< Salinity at point 2 - real, optional, intent(in) :: drdt1 !< drho_dt at point 1 - real, optional, intent(in) :: drds1 !< drho_ds at point 1 - real, optional, intent(in) :: drdt2 !< drho_dt at point 2 - real, optional, intent(in) :: drds2 !< drho_ds at point 2 - real, optional, intent(in) :: p1_in !< Pressure at point 1 - real, optional, intent(in) :: p2_in !< Pressure at point 2 +subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & + drdt1_out, drds1_out, drdp1_out, drdt2_out, drds2_out, drdp2_out ) + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + real, intent(in ) :: T1 !< Temperature at point 1 + real, intent(in ) :: S1 !< Salinity at point 1 + real, intent(in ) :: p1_in !< Pressure at point 1 + real, intent(in ) :: T2 !< Temperature at point 2 + real, intent(in ) :: S2 !< Salinity at point 2 + real, intent(in ) :: p2_in !< Pressure at point 2 + real, intent( out) :: drho !< Difference in density between the two points + real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 + real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 + real, optional, intent( out) :: dRdP1_out !< drho_dp at point 1 + real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 + real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 + real, optional, intent( out) :: dRdP2_out !< drho_ds at point 2 + ! Local variables real :: rho1, rho2, p1, p2, pmid + real :: drdt1, drdt2, drds1, drds2, drdp1, drdp2, rho_dummy ! Use the same reference pressure or the in-situ pressure if (CS%ref_pres > 0.) then @@ -1604,25 +1618,64 @@ real function calc_delta_rho(CS, T1, S1, T2, S2, drdt1, drds1, drdt2, drds2, p1_ pmid = 0.5 * (p1 + p2) call calculate_density( T1, S1, pmid, rho1, CS%EOS ) call calculate_density( T2, S2, pmid, rho2, CS%EOS ) - delta_rho = rho1 - rho2 - ! Use alpha and beta (without pressure dependence) - elseif (TRIM(CS%delta_rho_form) == 'no_pressure') then - if (.not. (PRESENT(drdt1) .and. PRESENT(drds1) .and. present(drdt2) .and. present(drds2)) ) then - call MOM_error(FATAL,"DELTA_RHO_FORM == linear requires drdt and drds") - else - delta_rho = 0.5 *( (drdt1+drdt2)*(T1-T2) + (drds1+drds2)*(S1-S2) ) - endif + call calculate_compress(T1, S1, pmid, rho_dummy, drdp1, CS%EOS) + call calculate_compress(T2, S2, pmid, rho_dummy, drdp2, CS%EOS) + drho = rho1 - rho2 + ! Use the density derivatives at the average of pressures and the differentces int temperature elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then pmid = 0.5 * (p1 + p2) if (CS%ref_pres>=0) pmid = CS%ref_pres - call calculate_density_derivs(T1, S1, pmid, CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS) - delta_rho = 0.5 *( (drdt1+drdt2)*(T1-T2) + (drds1+drds2)*(S1-S2) ) + call calculate_density_derivs(T1, S1, pmid, drdt1, drds1, CS%EOS) + call calculate_density_derivs(T2, S2, pmid, drdt2, drds2, CS%EOS) + call calculate_compress(T1, S1, pmid, rho_dummy, drdp1, CS%EOS) + call calculate_compress(T2, S2, pmid, rho_dummy, drdp2, CS%EOS) + drdp1 = drdp1*1.e-3 ; drdp2 = drdp2*1.e-3 + ! No pressure term since all derivatives have been calculated relative to midpoint pressure + drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, drdp1, T2, S2, P2, drdt2, drds2, drdp2 ) + elseif (TRIM(CS%delta_rho_form) == 'local_pressure') then + call calculate_density_derivs(T1, S1, p1, drdt1, drds1, CS%EOS) + call calculate_density_derivs(T2, S2, p2, drdt2, drds2, CS%EOS) + call calculate_compress(T1, S1, p1, rho_dummy, drdp1, CS%EOS) + call calculate_compress(T2, S2, p2, rho_dummy, drdp2, CS%EOS) + drdp1 = drdp1*1.e-3 ; drdp2 = drdp2*1.e-3 + drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, drdp1, T2, S2, P2, drdt2, drds2, drdp2 ) else - call MOM_error(FATAL, "delta_rho_form is not recognized") + call MOM_error(FATAL, "delta_rho_form is not recognized") endif -end function calc_delta_rho + if (PRESENT(drdt1_out)) drdt1_out = drdt1 + if (PRESENT(drds1_out)) drds1_out = drds1 + if (PRESENT(drdp1_out)) drdp1_out = drdp1 + if (PRESENT(drdt2_out)) drdt2_out = drdt2 + if (PRESENT(drds2_out)) drds2_out = drds2 + if (PRESENT(drdp2_out)) drdp2_out = drdp2 + +end subroutine calc_delta_rho_and_derivs + +!> Calculate delta rho from derivatives and gradients of properties +!! $\Delta \rho$ = \frac{1}{2}\left[ (\alpha_1 + \alpha_2)*(T_1-T_2) + +!! (\beta_1 + \beta_2)*(S_1-S_2) + +!! (\gamma^{-1}_1 + \gamma%{-1}_2)*(P_1-P_2) \right] +function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, dRdP1, & + T2, S2, P2, dRdT2, dRdS2, dRdP2 ) result (drho) + real :: T1 !< Temperature at point 1 + real :: S1 !< Salinity at point 1 + real :: P1 !< Pressure at point 1 + real :: dRdT1 !< Pressure at point 1 + real :: dRdS1 !< Pressure at point 1 + real :: dRdP1 !< Pressure at point 1 + real :: T2 !< Temperature at point 2 + real :: S2 !< Salinity at point 2 + real :: P2 !< Pressure at point 2 + real :: dRdT2 !< Pressure at point 2 + real :: dRdS2 !< Pressure at point 2 + real :: dRdP2 !< Pressure at point 2 + ! Local variables + real :: drho + + drho = 0.5 * ( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2) + (dRdP1+dRdP2)*(P1-P2) ) +end function delta_rho_from_derivs !> 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 @@ -2156,7 +2209,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure 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 + real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T + real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S real, dimension(nk,2) :: dRdT, dRdS logical, dimension(nk) :: stable_l, stable_r integer :: iMethod @@ -2173,13 +2227,13 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! 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. - dRdT(:,:) = -1. ; dRdS(:,:) = 0. - + allocate(CS%EOS) + call EOS_manual_init(CS%EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 0.) + Sl(:) = 0. ; Sr(:) = 0. ; ; SiL(:,:) = 0. ; SiR(:,:) = 0. + ppoly_T_l(:,:) = 0.; ppoly_T_r(:,:) = 0. + ppoly_S_l(:,:) = 0.; ppoly_S_r(:,:) = 0. ! Intialize any control structures needed for unit tests CS%ref_pres = -1. - allocate(remap_CS) - call initialize_remapping( remap_CS, "PLM", boundary_extrapolation = .true. ) hL = (/10.,10.,10./) ; hR = (/10.,10.,10./) Pres_l(1,1) = 0. ; Pres_l(1,2) = hL(1) ; Pres_r(1,1) = 0. ; Pres_r(1,2) = hR(1) @@ -2189,396 +2243,205 @@ logical function ndiff_unit_tests_discontinuous(verbose) Pres_r(k,1) = Pres_r(k-1,2) Pres_r(k,2) = Pres_r(k,1) + hR(k) enddo - CS%delta_rho_form = 'no_pressure' + CS%delta_rho_form = 'mid_pressure' CS%neutral_pos_method = 1 - ! For ease of coding up unit tests, we explicitly hard code temperatures at layer interfaces - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff - 'Identical Columns') - - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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 - (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoR - (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Right slightly cooler') - - TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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 - (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoL - (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoR - (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Left slightly cooler') - - TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); - TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 1.00, 0.00, 0.00, 0.25, 0.50, 0.75, 1.00, 0.00, 0.00, 0.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff - 'Right more strongly stratified') - - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL - (/ 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Deep Mixed layer on the right') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL - (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff - 'Right unstratified column') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL - (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.25, 0.50, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff - 'Right unstratified column') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff - 'Identical columns with mixed layer') - - TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); - TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff - 'Left interior unstratified') - - TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); - TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Left mixed layer, Right unstable interior') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 0.75, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff - 'Left thick mixed layer, Right unstable mixed') - - TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Unstable mixed layers, left cooler') - - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff - 'Identical Columns') - - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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 - (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoR - (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Right slightly cooler') - - TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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 - (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoL - (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoR - (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Left slightly cooler') - - TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); - TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 1.00, 0.00, 0.00, 0.25, 0.50, 0.75, 1.00, 0.00, 0.00, 0.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff - 'Right more strongly stratified') - - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL - (/ 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Deep Mixed layer on the right') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL - (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff - 'Right unstratified column') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL - (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.25, 0.50, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff - 'Right unstratified column') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff - 'Identical columns with mixed layer') - - TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); - TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR - (/ 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoR - (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff - 'Left interior unstratified') - - TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); - TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Left mixed layer, Right unstable interior') - - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL - (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 0.75, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff - 'Left thick mixed layer, Right unstable mixed') - - TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); - call mark_unstable_cells( CS, nk, dRdT, dRdS, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, dRdT, dRdS, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, 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, 3, 3, 3, 3, 3 /), & ! KoR - (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoL - (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoR - (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff - 'Unstable mixed layers, left cooler') - - deallocate(remap_CS) -! -! allocate(EOS) -! call EOS_manual_init(EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 2.) -! ! Unit tests for refine_nondim_position -! ! Tests using Newton's method -! ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & -! 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( & -! 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( & -! 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( & -! 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( & -! 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( & -! CS, 20., 35., -1., 2., 0., 1., (/21., -2./), (/34., 2./), -1., 1., 0.), & -! "Temp/Salt stratified (Brent) ")) -! deallocate(EOS) -! + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical Columns') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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 + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Right slightly cooler') + + TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); + TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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 + (/ 0.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 0.00, 0.50, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left slightly cooler') + + TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); + TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 0.00, 0.25, 0.50, 0.75, 1.00, 0.00, 0.00, 0.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right more strongly stratified') + + TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Deep Mixed layer on the right') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.25, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Right unstratified column') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); + TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Identical columns with mixed layer') + + TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); + TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 3, 3, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR + (/ 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 1.00 /), & ! PoR + (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff + 'Left interior unstratified') + + TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); + TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Left mixed layer, Right unstable interior') + + TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL + (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 0.50, 0.75, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff + 'Left thick mixed layer, Right unstable mixed') + + TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); + TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, 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, 3, 3, 3, 3, 3 /), & ! KoR + (/ 0.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 1.00, 0.00, 0.00, 0.50, 1.00 /), & ! PoL + (/ 0.00, 0.00, 0.00, 1.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.50, 1.00, 1.00 /), & ! PoR + (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff + 'Unstable mixed layers, left cooler') + + call EOS_manual_init(CS%EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 2.) ! Tests for linearized version of searching the layer for neutral surface position ! EOS linear in T, uniform alpha CS%max_iter = 10 ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., 0., -0.2, 0., 0., -0.2, 0., 10., & - (/12.,-4./), (/34.,0./)), "Temp Uniform Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., 0., & + 0., -0.2, 0., 0., 10., -0.2, 0., 0., & + (/12.,-4./), (/34.,0./)), "Temp Uniform Linearized Alpha/Beta")) ! EOS linear in S, uniform beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 0., 0.8, 0., 0., 0.8, 10., & - (/12.,0./), (/34.,2./)), "Salt Uniform Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, 0., & + 0., 0., 0.8, 0., 10., 0., 0.8, 0., & + (/12.,0./), (/34.,2./)), "Salt Uniform Linearized Alpha/Beta")) ! EOS linear in T/S, uniform alpha/beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., -0.5, 0.5, 0., -0.5, 0.5, 0., -0.5, 0.5, 10., & - (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) - ! EOS linear in T, insensitive to + find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.5, 0.5, 0., & + 0., -0.5, 0.5, 0., 10., -0.5, 0.5, 0., & + (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) + ! EOS linear in T, insensitive to So ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., 0., -0.4, 0., 0., -0.6, 0., 10., & - (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) - ! EOS linear in S, insensitive to T + find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., 0.,& + 0., -0.4, 0., 0., 10., -0.6, 0., 0., & + (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) +! ! EOS linear in S, insensitive to T ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, 0., 0., 1.0, 0., 0., 0.5, 10., & - (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, 0., & + 0., 0., 1.0, 0., 10., 0., 0.5, 0., & + (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' end function ndiff_unit_tests_discontinuous diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 597b0fc822..e845a8fcfb 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -56,6 +56,8 @@ module MOM_tracer_hor_diff !! the CFL limit is not violated. logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within !! tracer_hor_diff. + logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been + !! exceeded type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -401,6 +403,9 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla if (CS%show_call_tree) call callTree_waypoint("Calling neutral diffusion (tracer_hordiff)",itt) if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) + if (CS%recalc_neutral_surf) then + call neutral_diffusion_calc_coeffs(G, GV, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + endif endif call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, CS%neutral_diffusion_CSp) enddo ! itt @@ -1438,6 +1443,10 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) "below this value. The number of diffusive iterations \n"//& "is often this value or the next greater integer.", & units="nondim", default=-1.0) + call get_param(param_File, mdl, "RECALC_NEUTRAL_SURF", CS%recalc_neutral_surf, & + "If true, then recalculate the neutral surfaces if the \n"//& + "diffusive CFL is exceeded. If false, assume that the \n"//& + "positions of the surfaces do not change \n", default = .false.) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & From cb0d5107e469310d1ac1127b5513486734ef9506 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 12 Mar 2019 09:33:19 -0700 Subject: [PATCH 022/259] Remove pressure dependencies on pressure calculations --- src/tracer/MOM_neutral_diffusion.F90 | 160 +++++++++++++-------------- 1 file changed, 77 insertions(+), 83 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index eb18b88f4a..fd8d6264a0 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -73,7 +73,6 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressure (Pa) 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 - real, allocatable, dimension(:,:,:,:) :: dRdP_i !< dRho/dp (kg/m3/pascal) 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 => NULL() !< A structure that is used to @@ -160,10 +159,8 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) "1. Delta_rho varies linearly, find 0 crossing \n"// & "2. Alpha and beta vary linearly from top to bottom, \n"// & " Newton's method for neutral position \n"// & - "3. Keep recalculating alpha and beta (no pressure \n"// & - " dependence) Newton's method for neutral position \n"// & - "4. Full nonlinear equation of state, Brent's method \n"// & - " for neutral position", default=2) + "3. Full nonlinear equation of state, use regula falsi \n"// & + " for neutral position", default=3) if (CS%neutral_pos_method > 4 .or. CS%neutral_pos_method < 0) then call MOM_error(FATAL,"Invalid option for NEUTRAL_POS_METHOD") endif @@ -209,7 +206,6 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) allocate(CS%P_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%P_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%dRdP_i(SZI_(G),SZJ_(G),SZK_(G),2)) ; CS%dRdP_i(:,:,:,:) = 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. @@ -335,16 +331,12 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) ! Calculate derivatives for the top interface 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_compress(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, rho_tmp(:), & - CS%dRdP_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 ! Calcualte derivatives at the bottom interface 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_compress(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, rho_tmp(:), & - CS%dRdP_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS) enddo endif enddo @@ -523,6 +515,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) 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 ) ) +! if (tracer%t(i,j,k) < 0.) then +! do ks = 1,CS%nsurf-1 +! print *, uFlx(I,j,ks), uFlx(I-1,j,ks), vFlx(i,J,ks), vFlx(i,J-1,ks) +! enddo +! endif enddo if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then @@ -1091,10 +1088,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: search_layer real :: dRho, dRhoTop, dRhoBot, hL, hR real :: z0, pos - real :: dRdT_from_top, dRdS_from_top, dRdP_from_top ! Density derivatives at the searched from interface - real :: dRdT_from_bot, dRdS_from_bot, dRdP_from_bot ! Density derivatives at the searched from interface - real :: dRdT_to_top, dRdS_to_top, dRdP_to_top ! Density derivatives at the interfaces being searched - real :: dRdT_to_bot, dRdS_to_bot, dRdP_to_bot ! Density derivatives at the interfaces being searched + real :: dRdT_from_top, dRdS_from_top ! Density derivatives at the searched from interface + real :: dRdT_from_bot, dRdS_from_bot ! Density derivatives at the searched from interface + real :: dRdT_to_top, dRdS_to_top ! Density derivatives at the interfaces being searched + real :: dRdT_to_bot, dRdS_to_bot ! Density derivatives at the interfaces being searched real :: T_ref, S_ref, P_ref, P_top, P_bot real :: lastP_left, lastP_right @@ -1212,11 +1209,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoR(k_surface) = kl_right if (CS%debug) then - write(*,'(A,I2)') "Searching left layer ", kl_left - 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) - write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) + write(*,'(A,I2)') "Searching right layer ", kl_right + 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 Top L: ", Tr(kl_right,1), Sr(kl_right,1) + write(*,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) endif call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) lastP_right = PoR(k_surface) @@ -1233,10 +1230,18 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, if ( KoL(k_surface) == KoL(k_surface-1) .and. KoR(k_surface) == KoR(k_surface-1) ) 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)) - if ( hL + hR == 0. ) then + if (hL < 0. .or. hR < 0.) then + call MOM_error(FATAL,"Negative thicknesses in neutral diffusion") + elseif ( hL + hR == 0. ) then hEff(k_surface-1) = 0. else hEff(k_surface-1) = 2. * ( (hL * hR) / ( hL + hR ) )! Harmonic mean + if ( KoL(k_surface) /= KoL(k_surface-1) ) then + call MOM_error(FATAL,"Neutral sublayer spans multiple layers") + endif + if ( KoR(k_surface) /= KoR(k_surface-1) ) then + call MOM_error(FATAL,"Neutral sublayer spans multiple layers") + endif endif else hEff(k_surface-1) = 0. @@ -1258,7 +1263,8 @@ subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) real :: delta_rho do k = 1,nk - call calc_delta_rho_and_derivs( CS, T(k,2), S(k,2), P(k,2), T(k,1), S(k,1), P(k,1), delta_rho ) + call calc_delta_rho_and_derivs( CS, T(k,2), S(k,2), max(P(k,2),CS%ref_pres), & + T(k,1), S(k,1), max(P(k,1),CS%ref_pres), delta_rho ) stable_cell(k) = delta_rho > 0. enddo end subroutine mark_unstable_cells @@ -1283,8 +1289,8 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction coefficients ! Local variables real :: dRhotop, dRhobot - real :: dRdT_top, dRdS_top, dRdP_top, dRdT_bot, dRdS_bot, dRdP_bot - real :: dRdT_from, dRdS_from, dRdP_from + real :: dRdT_top, dRdS_top, dRdT_bot, dRdS_bot + real :: dRdT_from, dRdS_from real :: P_mid ! Calculate the differencei in density at the tops or the bottom @@ -1293,26 +1299,33 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) elseif (CS%neutral_pos_method == 2) then call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop, & - dRdT_top, dRdS_top, dRdP_top, dRdT_from, dRdS_from, dRdP_from) + dRdT_top, dRdS_top, dRdT_from, dRdS_from) call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot, & - dRdT_bot, dRdS_bot, dRdP_bot, dRdT_from, dRdS_from, dRdP_from) + dRdT_bot, dRdS_bot, dRdT_from, dRdS_from) endif ! Handle all the special cases EXCEPT if it connects within the layer if ( (dRhoTop > 0.) .or. (ksurf == 1) ) then ! First interface or lighter than anything in layer - pos = 0. + pos = pos_last + if (CS%debug) print *, "Lighter" elseif ( dRhoTop > dRhoBot ) then ! Unstably stratified pos = 1. + if (CS%debug) print *, "Unstable" elseif ( dRhoTop < 0. .and. dRhoBot < 0.) then ! Denser than anything in layer pos = 1. + if (CS%debug) print *, "Denser" elseif ( dRhoTop == 0. .and. dRhoBot == 0. ) then ! Perfectly unstratified pos = 1. + if (CS%debug) print *, "Unstratified" elseif ( dRhoBot == 0. ) then ! Matches perfectly at the Top pos = 1. + if (CS%debug) print *, "Bottom" elseif ( dRhoTop == 0. ) then ! Matches perfectly at the Bottom - pos = 0. + pos = pos_last + if (CS%debug) print *, "Top" else ! Neutral surface within layer pos = -1 + if (CS%debug) print *, "Interpolate" endif ! Can safely return if position is >= 0 otherwise will need to find the position within the layer @@ -1323,9 +1336,9 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T ! For the 'Linear' case of finding the neutral position, the fromerence pressure to use is the average ! of the midpoint of the layer being searched and the interface being searched from elseif (CS%neutral_pos_method == 2) then - pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, P_from, dRdT_from, dRdS_from, dRdP_from, & - P_top, dRdT_top, dRdS_top, dRdP_top, & - P_bot, dRdT_bot, dRdS_bot, dRdP_bot, T_poly, S_poly ) + pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, P_from, dRdT_from, dRdS_from, & + P_top, dRdT_top, dRdS_top, & + P_bot, dRdT_bot, dRdS_bot, T_poly, S_poly ) elseif (CS%neutral_pos_method == 3) then pos = find_neutral_pos_full( CS, pos_last, T_from, S_from, P_from, P_top, P_bot, T_poly, S_poly) endif @@ -1367,9 +1380,9 @@ end subroutine increment_interface !! interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta means that second !! derivatives of the EOS are not needed. Note that delta in variable names below refers to horizontal differences and !! 'd' refers to vertical differences -function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref, & - P_top, dRdT_top, dRdS_top, dRdP_top, & - P_bot, dRdT_bot, dRdS_bot, dRdP_bot, ppoly_T, ppoly_S ) result( z ) +function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & + P_top, dRdT_top, dRdS_top, & + P_bot, dRdT_bot, dRdS_bot, ppoly_T, ppoly_S ) result( z ) type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess real, intent(in) :: T_ref !< Temperature at the searched from interface @@ -1377,24 +1390,21 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r real, intent(in) :: P_ref !< Pressure at the searched from interface real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface - real, intent(in) :: dRdP_ref !< dRho/dP at the searched from interface real, intent(in) :: P_top !< Pressure at top of layer being searched real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched - real, intent(in) :: dRdP_top !< dRho/dP at top of layer being searched real, intent(in) :: P_bot !< Pressure at bottom of layer being searched real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched - real, intent(in) :: dRdP_bot !< dRho/dP at bottom of layer being searched real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within !! the layer to be searched. real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within !! the layer to be searched. real :: z !< Position where drho = 0 ! Local variables - real :: dRdT_diff, dRdS_diff, dRdP_diff, dRdP_z + real :: dRdT_diff, dRdS_diff real :: drho, drho_dz, dRdT_z, dRdS_z, T_z, S_z, deltaT, deltaS, deltaP, dT_dz, dS_dz - real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dRdP_sum, dz, P_z, dP_dz + real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dz, P_z, dP_dz real :: a1, a2 integer :: iter integer :: nterm @@ -1405,7 +1415,6 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r ! Position independent quantities dRdT_diff = dRdT_bot - dRdT_top dRdS_diff = dRdS_bot - dRdS_top - dRdP_diff = dRdP_bot - dRdP_top ! Assume a linear increase in pressure from top and bottom of the cell dP_dz = P_bot - P_top ! Initial starting drho (used for bisection) @@ -1417,15 +1426,14 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r S_z = evaluation_polynomial( ppoly_S, nterm, zmin ) dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot - dRdP_z = a1*dRdP_top + a2*dRdP_bot P_z = a1*P_top + a2*P_bot - drho_min = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, dRdP_z, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref) + drho_min = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, & + T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) T_z = evaluation_polynomial( ppoly_T, nterm, 1. ) S_z = evaluation_polynomial( ppoly_S, nterm, 1. ) - drho_max = delta_rho_from_derivs(T_z, S_z, P_bot, dRdT_bot, dRdS_bot, dRdP_bot, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref) + drho_max = delta_rho_from_derivs(T_z, S_z, P_bot, dRdT_bot, dRdS_bot, & + T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) if (drho_min >= 0.) then z = z0 @@ -1435,6 +1443,7 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r return endif if ( SIGN(1.,drho_min) == SIGN(1.,drho_max) ) then + print *, drho_min, drho_max call MOM_error(FATAL, "drho_min is the same sign as dhro_max") endif @@ -1446,7 +1455,6 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r a2 = z dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot - dRdP_z = a1*dRdP_top + a2*dRdP_bot T_z = evaluation_polynomial( ppoly_T, nterm, z ) S_z = evaluation_polynomial( ppoly_S, nterm, z ) P_z = a1*P_top + a2*P_bot @@ -1455,9 +1463,8 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r deltaP = P_z - P_ref dRdT_sum = dRdT_ref + dRdT_z dRdS_sum = dRdS_ref + dRdS_z - dRdP_sum = dRdP_ref + dRdP_z - drho = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, dRdP_z, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, dRdP_ref) + drho = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, & + T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) ! Check for convergence if (ABS(drho) <= CS%drho_tol) exit @@ -1473,10 +1480,9 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r ! Calculate a Newton step dT_dz = first_derivative_polynomial( ppoly_T, nterm, z ) dS_dz = first_derivative_polynomial( ppoly_S, nterm, z ) - drho_dz = 0.5*( (dRdT_diff*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) + & - (dRdP_diff*deltaP + dRdP_sum*dP_dz) ) - ztest = z - drho/drho_dz + drho_dz = 0.5*( (dRdT_diff*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) ) + ztest = z - drho/drho_dz ! Take a bisection if z falls out of [zmin,zmax] if (ztest < zmin .or. ztest > zmax) then if ( drho < 0. ) then @@ -1542,7 +1548,10 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly return endif if ( SIGN(1.,drho_b) == SIGN(1.,drho_c) ) then - call MOM_error(FATAL, "drho_min is the same sign as dhro_max") + print *, drho_b, drho_c + call MOM_error(WARNING, "drho_b is the same sign as dhro_c") + z = z0 + return endif do iter = 1, CS%max_iter @@ -1585,7 +1594,7 @@ end function find_neutral_pos_full !> Calculate the difference in density between two points in a variety of ways subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & - drdt1_out, drds1_out, drdp1_out, drdt2_out, drds2_out, drdp2_out ) + drdt1_out, drds1_out, drdt2_out, drds2_out ) type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure real, intent(in ) :: T1 !< Temperature at point 1 real, intent(in ) :: S1 !< Salinity at point 1 @@ -1596,10 +1605,8 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, real, intent( out) :: drho !< Difference in density between the two points real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 - real, optional, intent( out) :: dRdP1_out !< drho_dp at point 1 real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 - real, optional, intent( out) :: dRdP2_out !< drho_ds at point 2 ! Local variables real :: rho1, rho2, p1, p2, pmid real :: drdt1, drdt2, drds1, drds2, drdp1, drdp2, rho_dummy @@ -1618,8 +1625,6 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, pmid = 0.5 * (p1 + p2) call calculate_density( T1, S1, pmid, rho1, CS%EOS ) call calculate_density( T2, S2, pmid, rho2, CS%EOS ) - call calculate_compress(T1, S1, pmid, rho_dummy, drdp1, CS%EOS) - call calculate_compress(T2, S2, pmid, rho_dummy, drdp2, CS%EOS) drho = rho1 - rho2 ! Use the density derivatives at the average of pressures and the differentces int temperature elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then @@ -1627,28 +1632,19 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, if (CS%ref_pres>=0) pmid = CS%ref_pres call calculate_density_derivs(T1, S1, pmid, drdt1, drds1, CS%EOS) call calculate_density_derivs(T2, S2, pmid, drdt2, drds2, CS%EOS) - call calculate_compress(T1, S1, pmid, rho_dummy, drdp1, CS%EOS) - call calculate_compress(T2, S2, pmid, rho_dummy, drdp2, CS%EOS) - drdp1 = drdp1*1.e-3 ; drdp2 = drdp2*1.e-3 - ! No pressure term since all derivatives have been calculated relative to midpoint pressure - drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, drdp1, T2, S2, P2, drdt2, drds2, drdp2 ) + drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, T2, S2, P2, drdt2, drds2) elseif (TRIM(CS%delta_rho_form) == 'local_pressure') then call calculate_density_derivs(T1, S1, p1, drdt1, drds1, CS%EOS) call calculate_density_derivs(T2, S2, p2, drdt2, drds2, CS%EOS) - call calculate_compress(T1, S1, p1, rho_dummy, drdp1, CS%EOS) - call calculate_compress(T2, S2, p2, rho_dummy, drdp2, CS%EOS) - drdp1 = drdp1*1.e-3 ; drdp2 = drdp2*1.e-3 - drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, drdp1, T2, S2, P2, drdt2, drds2, drdp2 ) + drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, T2, S2, P2, drdt2, drds2) else call MOM_error(FATAL, "delta_rho_form is not recognized") endif if (PRESENT(drdt1_out)) drdt1_out = drdt1 if (PRESENT(drds1_out)) drds1_out = drds1 - if (PRESENT(drdp1_out)) drdp1_out = drdp1 if (PRESENT(drdt2_out)) drdt2_out = drdt2 if (PRESENT(drds2_out)) drds2_out = drds2 - if (PRESENT(drdp2_out)) drdp2_out = drdp2 end subroutine calc_delta_rho_and_derivs @@ -1656,24 +1652,22 @@ end subroutine calc_delta_rho_and_derivs !! $\Delta \rho$ = \frac{1}{2}\left[ (\alpha_1 + \alpha_2)*(T_1-T_2) + !! (\beta_1 + \beta_2)*(S_1-S_2) + !! (\gamma^{-1}_1 + \gamma%{-1}_2)*(P_1-P_2) \right] -function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, dRdP1, & - T2, S2, P2, dRdT2, dRdS2, dRdP2 ) result (drho) +function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, & + T2, S2, P2, dRdT2, dRdS2 ) result (drho) real :: T1 !< Temperature at point 1 real :: S1 !< Salinity at point 1 real :: P1 !< Pressure at point 1 real :: dRdT1 !< Pressure at point 1 real :: dRdS1 !< Pressure at point 1 - real :: dRdP1 !< Pressure at point 1 real :: T2 !< Temperature at point 2 real :: S2 !< Salinity at point 2 real :: P2 !< Pressure at point 2 real :: dRdT2 !< Pressure at point 2 real :: dRdS2 !< Pressure at point 2 - real :: dRdP2 !< Pressure at point 2 ! Local variables real :: drho - drho = 0.5 * ( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2) + (dRdP1+dRdP2)*(P1-P2) ) + drho = 0.5 * ( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2 )) end function delta_rho_from_derivs !> Converts non-dimensional position within a layer to absolute position (for debugging) @@ -2419,28 +2413,28 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! EOS linear in T, uniform alpha CS%max_iter = 10 ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., 0., & - 0., -0.2, 0., 0., 10., -0.2, 0., 0., & + find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., & + 0., -0.2, 0., 10., -0.2, 0., & (/12.,-4./), (/34.,0./)), "Temp Uniform Linearized Alpha/Beta")) ! EOS linear in S, uniform beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, 0., & - 0., 0., 0.8, 0., 10., 0., 0.8, 0., & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, & + 0., 0., 0.8, 10., 0., 0.8, & (/12.,0./), (/34.,2./)), "Salt Uniform Linearized Alpha/Beta")) ! EOS linear in T/S, uniform alpha/beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.5, 0.5, 0., & - 0., -0.5, 0.5, 0., 10., -0.5, 0.5, 0., & + find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.5, 0.5, & + 0., -0.5, 0.5, 10., -0.5, 0.5, & (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) ! EOS linear in T, insensitive to So ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., 0.,& - 0., -0.4, 0., 0., 10., -0.6, 0., 0., & + find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., & + 0., -0.4, 0., 10., -0.6, 0., & (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) ! ! EOS linear in S, insensitive to T ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, 0., & - 0., 0., 1.0, 0., 10., 0., 0.5, 0., & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, & + 0., 0., 1.0, 10., 0., 0.5, & (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' From 11cb7ad12eb09d4c0cc6ac8aa184b9d67e52dc95 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 12 Mar 2019 09:56:34 -0700 Subject: [PATCH 023/259] Remove MOM_neutral_diffusion_aux since it's no longer used --- src/tracer/MOM_neutral_diffusion.F90 | 2 +- src/tracer/MOM_neutral_diffusion_aux.F90 | 457 ----------------------- 2 files changed, 1 insertion(+), 458 deletions(-) delete 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 fd8d6264a0..43b08d30f6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1290,7 +1290,7 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T ! Local variables real :: dRhotop, dRhobot real :: dRdT_top, dRdS_top, dRdT_bot, dRdS_bot - real :: dRdT_from, dRdS_from + real :: dRdT_from, dRdS_from real :: P_mid ! Calculate the differencei in density at the tops or the bottom diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 deleted file mode 100644 index 0b23baae29..0000000000 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ /dev/null @@ -1,457 +0,0 @@ -!> 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 set_ndiff_aux_params -public calc_drho -public drho_at_pos -public refine_nondim_position -public check_neutral_positions -public kahan_sum - -!> The control structure for this module -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 - logical :: debug !< If true, write verbose debugging messages and checksusm - 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, 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 - 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 - 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 - 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 - if (present( debug )) CS%debug = debug - -end subroutine set_ndiff_aux_params - -!> 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 -!! 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 - 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(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(out) :: delta_rho !< The density difference from a reference value - 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, CS%nterm, x0 ) - S = evaluation_polynomial( ppoly_S, CS%nterm, x0 ) - ! Interpolated pressure if using locally referenced neutral density - 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, CS%ref_pres, alpha, beta, CS%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 drho_at_pos - -!> 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(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 - 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 - 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 - real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP - 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 - - machep = EPSILON(machep) - 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(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 (CS%force_brent) then - do_newton = .not. CS%force_brent - do_brent = CS%force_brent - endif - - ! Calculate the initial values - 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) <= CS%drho_tol ) then - refine_nondim_position = min_bound - return - endif - if (ABS(drho_bot) <= CS%drho_tol) then - refine_nondim_position = 1. - return - endif - - ! Set the initial values to ensure that the algorithm returns a 'negative' value - neg_fun = delta_rho - neg_x = min_bound - - if (CS%debug) then - write (*,*) "------" - 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 - ! 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) - 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, CS%max_iter - P_int = P_top*(1. - b) + P_bot*b - ! Evaluate total derivative of delta_rho - 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 (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, 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 take a bisection - if (d_delta_rho_dP == 0.) then - b = 0.5*(a+c) - 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) then - b = 0.5*(a + c) - 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) 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 - 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 - 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 - - ! Update the bracket - if (SIGN(1.,fa)*SIGN(1.,fb)<0.) then - c = b - fc = delta_rho - else - a = b - fa = delta_rho - endif - enddo - 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 - sb = 1. ; fb = drho_bot - c = sa ; fc = fa ; e = sb - sa; d = e - - - ! This is from https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.f90 - do iter = 1,CS%max_iter - if ( abs ( fc ) < abs ( fb ) ) then - sa = sb - sb = c - c = sa - fa = fb - fb = fc - fc = fa - endif - tol = 2. * machep * abs ( sb ) + CS%xtol - m = 0.5 * ( c - sb ) - if ( abs ( m ) <= tol .or. fb == 0. ) then - exit - endif - if ( abs ( e ) < tol .or. abs ( fa ) <= abs ( fb ) ) then - e = m - d = e - else - s0 = fb / fa - if ( sa == c ) then - p = 2. * m * s0 - q = 1. - s0 - else - q = fa / fc - r = fb / fc - p = s0 * ( 2. * m * q * ( q - r ) - ( sb - sa ) * ( r - 1. ) ) - q = ( q - 1. ) * ( r - 1. ) * ( s0 - 1. ) - endif - if ( 0. < p ) then - q = - q - else - p = - p - endif - s0 = e - e = d - if ( 2. * p < 3. * m * q - abs ( tol * q ) .and. & - p < abs ( 0.5 * s0 * q ) ) then - d = p / q - else - e = m - d = e - endif - endif - sa = sb - fa = fb - if ( tol < abs ( d ) ) then - sb = sb + d - elseif ( 0. < m ) then - sb = sb + tol - else - sb = sb - tol - endif - 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 - fc = fa - e = sb - sa - d = e - endif - enddo - ! Modified from original to ensure that the minimum is found - fa = ABS(fa) ; fb = ABS(fb) ; fc = ABS(fc) - delta_rho = MIN(fa, fb, fc) - - if (fb==delta_rho) then - refine_nondim_position = max(sb,min_bound) - elseif (fa==delta_rho) then - refine_nondim_position = max(sa,min_bound) - elseif (fc==delta_rho) then - refine_nondim_position = max(c, min_bound) - endif - endif - - ! Make sure that the result is bounded between 0 and 1 - if (refine_nondim_position>1.) 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 - write (*,*) "S_ref, beta_ref : ", S_ref, beta_ref - write (*,*) "x0: ", min_bound - write (*,*) "refine_nondim_position: ", refine_nondim_position - endif - call MOM_error(WARNING, "refine_nondim_position>1.") - refine_nondim_position = 1. - endif - - if (refine_nondim_position 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 10e8d7c10f26f657ed787b16a28ca97bae717b80 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 30 Aug 2019 20:23:43 +0000 Subject: [PATCH 024/259] Added testing output to .gitignore --- .gitignore | 13 ------------- .testing/.gitignore | 6 ++++-- 2 files changed, 4 insertions(+), 15 deletions(-) diff --git a/.gitignore b/.gitignore index 0b3138728d..e534738ed7 100644 --- a/.gitignore +++ b/.gitignore @@ -6,16 +6,3 @@ html MOM6 build/ deps/ -#.testing/*/available_diags.* -#.testing/*/CPU_stats -#.testing/*/chksum_diag -#.testing/*/exitcode -#.testing/*/logfile.*.out -#.testing/*/MOM_parameter_doc.* -#.testing/*/ocean_geometry.nc -#.testing/*/ocean.stats -#.testing/*/ocean.stats.nc -#.testing/*/RESTART/ -#.testing/*/time_stamp.out -#.testing/*/Vertical_coordinate.nc -#.testing/*/GOLD_IC.nc diff --git a/.testing/.gitignore b/.testing/.gitignore index f119a40591..a096823fcd 100644 --- a/.testing/.gitignore +++ b/.testing/.gitignore @@ -5,9 +5,11 @@ exitcode logfile.*.out MOM_parameter_doc.* ocean_geometry.nc -ocean.stats -ocean.stats.nc +ocean.stats* RESTART/ time_stamp.out Vertical_coordinate.nc GOLD_IC.nc +debug.out +chksum_diag.* +config.mk From db75cce5c4dca6a31bd6aca6a3e96b0cb08caf3b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 30 Aug 2019 20:33:38 +0000 Subject: [PATCH 025/259] Reduce diag_tables in .testing --- .testing/tc0/diag_table | 2 +- .testing/tc1/diag_table | 78 +-------------- .testing/tc2/diag_table | 86 +---------------- .testing/tc3/diag_table | 207 +--------------------------------------- 4 files changed, 4 insertions(+), 369 deletions(-) diff --git a/.testing/tc0/diag_table b/.testing/tc0/diag_table index 1527de166b..091dc46933 100644 --- a/.testing/tc0/diag_table +++ b/.testing/tc0/diag_table @@ -1,2 +1,2 @@ -"Unit tests" +"MOM test configuration 0" 1 1 1 0 0 0 diff --git a/.testing/tc1/diag_table b/.testing/tc1/diag_table index 19d6a32e1e..220d65d34f 100644 --- a/.testing/tc1/diag_table +++ b/.testing/tc1/diag_table @@ -1,86 +1,10 @@ -"MOM benchmark Experiment" +"MOM test configuration 1" 1 1 1 0 0 0 "prog", 1,"days",1,"days","time", -#"ave_prog", 5,"days",1,"days","Time",365,"days" -#"cont", 5,"days",1,"days","Time",365,"days" - -#This is the field section of the diag_table. # Prognostic Ocean fields: -#========================= - "ocean_model","u","u","prog","all",.false.,"none",2 "ocean_model","v","v","prog","all",.false.,"none",2 "ocean_model","h","h","prog","all",.false.,"none",1 "ocean_model","e","e","prog","all",.false.,"none",2 "ocean_model","temp","temp","prog","all",.false.,"none",2 -#"ocean_model","salt","salt","prog","all",.false.,"none",2 - -#"ocean_model","u","u","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","v","v","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","h","h","ave_prog_%4yr_%3dy","all",.true.,"none",1 -#"ocean_model","e","e","ave_prog_%4yr_%3dy","all",.true.,"none",2 - -# Auxilary Tracers: -#================== -#"ocean_model","vintage","vintage","prog_%4yr_%3dy","all",.false.,"none",2 -#"ocean_model","age","age","prog_%4yr_%3dy","all",.false.,"none",2 - -# Continuity Equation Terms: -#=========================== -#"ocean_model","dhdt","dhdt","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","wd","wd","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","uh","uh","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","vh","vh","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","h_rho","h_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","uh_rho","uh_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","vh_rho","vh_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","uhGM_rho","uhGM_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","vhGM_rho","vhGM_rho","cont_%4yr_%3dy","all",.true.,"none",2 - -# -# Tracer Fluxes: -#================== -#"ocean_model","T_adx", "T_adx", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","T_ady", "T_ady", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","T_diffx","T_diffx","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","T_diffy","T_diffy","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_adx", "S_adx", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_ady", "S_ady", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_diffx","S_diffx","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_diffy","S_diffy","ave_prog_%4yr_%3dy","all",.true.,"none",2 - -#============================================================================================= -# -#===- This file can be used with diag_manager/v2.0a (or higher) ==== -# -# -# FORMATS FOR FILE ENTRIES (not all input values are used) -# ------------------------ -# -#"file_name", output_freq, "output_units", format, "time_units", "time_long_name", ... -# (opt) new_file_frequecy, (opt) "new_file_freq_units", "new_file_start_date" -# -# -#output_freq: > 0 output frequency in "output_units" -# = 0 output frequency every time step -# =-1 output frequency at end of run -# -#output_units = units used for output frequency -# (years, months, days, minutes, hours, seconds) -# -#time_units = units used to label the time axis -# (days, minutes, hours, seconds) -# -# -# FORMAT FOR FIELD ENTRIES (not all input values are used) -# ------------------------ -# -#"module_name", "field_name", "output_name", "file_name" "time_sampling", time_avg, "other_opts", packing -# -#time_avg = .true. or .false. -# -#packing = 1 double precision -# = 2 float -# = 4 packed 16-bit integers -# = 8 packed 1-byte (not tested?) diff --git a/.testing/tc2/diag_table b/.testing/tc2/diag_table index 19d6a32e1e..941b9c0c15 100644 --- a/.testing/tc2/diag_table +++ b/.testing/tc2/diag_table @@ -1,86 +1,2 @@ -"MOM benchmark Experiment" +"MOM test configuration 2" 1 1 1 0 0 0 -"prog", 1,"days",1,"days","time", -#"ave_prog", 5,"days",1,"days","Time",365,"days" -#"cont", 5,"days",1,"days","Time",365,"days" - -#This is the field section of the diag_table. - -# Prognostic Ocean fields: -#========================= - -"ocean_model","u","u","prog","all",.false.,"none",2 -"ocean_model","v","v","prog","all",.false.,"none",2 -"ocean_model","h","h","prog","all",.false.,"none",1 -"ocean_model","e","e","prog","all",.false.,"none",2 -"ocean_model","temp","temp","prog","all",.false.,"none",2 -#"ocean_model","salt","salt","prog","all",.false.,"none",2 - -#"ocean_model","u","u","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","v","v","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","h","h","ave_prog_%4yr_%3dy","all",.true.,"none",1 -#"ocean_model","e","e","ave_prog_%4yr_%3dy","all",.true.,"none",2 - -# Auxilary Tracers: -#================== -#"ocean_model","vintage","vintage","prog_%4yr_%3dy","all",.false.,"none",2 -#"ocean_model","age","age","prog_%4yr_%3dy","all",.false.,"none",2 - -# Continuity Equation Terms: -#=========================== -#"ocean_model","dhdt","dhdt","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","wd","wd","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","uh","uh","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","vh","vh","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","h_rho","h_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","uh_rho","uh_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","vh_rho","vh_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","uhGM_rho","uhGM_rho","cont_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","vhGM_rho","vhGM_rho","cont_%4yr_%3dy","all",.true.,"none",2 - -# -# Tracer Fluxes: -#================== -#"ocean_model","T_adx", "T_adx", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","T_ady", "T_ady", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","T_diffx","T_diffx","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","T_diffy","T_diffy","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_adx", "S_adx", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_ady", "S_ady", "ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_diffx","S_diffx","ave_prog_%4yr_%3dy","all",.true.,"none",2 -#"ocean_model","S_diffy","S_diffy","ave_prog_%4yr_%3dy","all",.true.,"none",2 - -#============================================================================================= -# -#===- This file can be used with diag_manager/v2.0a (or higher) ==== -# -# -# FORMATS FOR FILE ENTRIES (not all input values are used) -# ------------------------ -# -#"file_name", output_freq, "output_units", format, "time_units", "time_long_name", ... -# (opt) new_file_frequecy, (opt) "new_file_freq_units", "new_file_start_date" -# -# -#output_freq: > 0 output frequency in "output_units" -# = 0 output frequency every time step -# =-1 output frequency at end of run -# -#output_units = units used for output frequency -# (years, months, days, minutes, hours, seconds) -# -#time_units = units used to label the time axis -# (days, minutes, hours, seconds) -# -# -# FORMAT FOR FIELD ENTRIES (not all input values are used) -# ------------------------ -# -#"module_name", "field_name", "output_name", "file_name" "time_sampling", time_avg, "other_opts", packing -# -#time_avg = .true. or .false. -# -#packing = 1 double precision -# = 2 float -# = 4 packed 16-bit integers -# = 8 packed 1-byte (not tested?) diff --git a/.testing/tc3/diag_table b/.testing/tc3/diag_table index e31244cbd4..64043b6e0d 100644 --- a/.testing/tc3/diag_table +++ b/.testing/tc3/diag_table @@ -1,207 +1,2 @@ -"MOM Experiment" +"MOM test configuration 3" 1 1 1 0 0 0 -"prog", 2,"minutes",1,"days","Time", -#"ave_prog", 1,"hours",1,"days","Time", -#"cont", 1,"hours",1,"days","Time", -#"trac", 5,"days",1,"days","Time", -#"mom", 5,"days",1,"days","Time", -#"bt_mom", 5,"days",1,"days","Time", -#"visc", 5,"days",1,"days","Time", -#"energy", 5,"days",1,"days","Time", -#"ML_TKE", 5,"days",1,"days","Time", -#"forcing", 5,"days",1,"days","Time", - -#This is the field section of the diag_table. - -# Prognostic Ocean fields: -#========================= - -"ocean_model","u","u","prog","all",.false.,"none",2 -"ocean_model","v","v","prog","all",.false.,"none",2 -"ocean_model","h","h","prog","all",.false.,"none",1 -"ocean_model","e","e","prog","all",.false.,"none",2 -#"ocean_model","SSH","SSH","prog","all",.false.,"none",2 -#"ocean_model","temp","temp","prog","all",.false.,"none",2 -#"ocean_model","salt","salt","prog","all",.false.,"none",2 -#"ocean_model","Rml","Rml","prog","all",.false.,"none",2 -#"ocean_model","tr_D1","tr1","prog","all",.false.,"none",2 - -#"ocean_model","RV","RV","prog","all",.false.,"none",2 -#"ocean_model","PV","PV","prog","all",.false.,"none",2 -#"ocean_model","e_D","e_D","prog","all",.false.,"none",2 - -#"ocean_model","u","u","ave_prog","all",.true.,"none",2 -#"ocean_model","v","v","ave_prog","all",.true.,"none",2 -#"ocean_model","h","h","ave_prog","all",.true.,"none",1 -#"ocean_model","e","e","ave_prog","all",.true.,"none",2 -#"ocean_model","temp","temp","ave_prog","all",.true.,"none",2 -#"ocean_model","salt","salt","ave_prog","all",.true.,"none",2 -#"ocean_model","Rml","Rml","ave_prog","all",.true.,"none",2 - -# Auxilary Tracers: -#================== -#"ocean_model","vintage","vintage","prog","all",.false.,"none",2 -#"ocean_model","age","age","prog","all",.false.,"none",2 - -# Tracers: -#========= -#"ocean_model","tr_D1","tr1","trac","all",.false.,"none",2 -#"ocean_model","tr_D2","tr2","trac","all",.false.,"none",2 -#"ocean_model","tr_D3","tr3","trac","all",.false.,"none",2 -#"ocean_model","tr_D4","tr4","trac","all",.false.,"none",2 -#"ocean_model","tr_D5","tr5","trac","all",.false.,"none",2 -#"ocean_model","tr_D6","tr6","trac","all",.false.,"none",2 -#"ocean_model","tr_D7","tr7","trac","all",.false.,"none",2 -#"ocean_model","tr_D8","tr8","trac","all",.false.,"none",2 -#"ocean_model","tr_D9","tr9","trac","all",.false.,"none",2 -#"ocean_model","tr_D10","tr10","trac","all",.false.,"none",2 -#"ocean_model","tr_D11","tr11","trac","all",.false.,"none",2 - -# Continuity Equation Terms: -#=========================== -#"ocean_model","dhdt","dhdt","cont","all",.true.,"none",2 -#"ocean_model","wd","wd","cont","all",.true.,"none",2 -#"ocean_model","uh","uh","cont","all",.true.,"none",2 -#"ocean_model","vh","vh","cont","all",.true.,"none",2 -#"ocean_model","uhGM","uhGM","cont","all",.true.,"none",2 -#"ocean_model","vhGM","vhGM","cont","all",.true.,"none",2 -#"ocean_model","uhbt","uhbt","cont","all",.true.,"none",2 -#"ocean_model","vhbt","vhbt","cont","all",.true.,"none",2 - -# Continuity Equation Terms In Pure Potential Density Coordiantes: -#================================================================= -#"ocean_model","h_rho","h_rho","cont","all",.true.,"none",2 -#"ocean_model","uh_rho","uh_rho","cont","all",.true.,"none",2 -#"ocean_model","vh_rho","vh_rho","cont","all",.true.,"none",2 -#"ocean_model","uhGM_rho","uhGM_rho","cont","all",.true.,"none",2 -#"ocean_model","vhGM_rho","vhGM_rho","cont","all",.true.,"none",2 - -# -# Tracer Fluxes: -#================== -#"ocean_model","T_adx", "T_adx", "ave_prog","all",.true.,"none",2 -#"ocean_model","T_ady", "T_ady", "ave_prog","all",.true.,"none",2 -#"ocean_model","T_diffx","T_diffx","ave_prog","all",.true.,"none",2 -#"ocean_model","T_diffy","T_diffy","ave_prog","all",.true.,"none",2 -#"ocean_model","S_adx", "S_adx", "ave_prog","all",.true.,"none",2 -#"ocean_model","S_ady", "S_ady", "ave_prog","all",.true.,"none",2 -#"ocean_model","S_diffx","S_diffx","ave_prog","all",.true.,"none",2 -#"ocean_model","S_diffy","S_diffy","ave_prog","all",.true.,"none",2 - - -# Momentum Balance Terms: -#======================= -#"ocean_model","dudt","dudt","mom","all",.true.,"none",2 -#"ocean_model","dvdt","dvdt","mom","all",.true.,"none",2 -#"ocean_model","CAu","CAu","mom","all",.true.,"none",2 -#"ocean_model","CAv","CAv","mom","all",.true.,"none",2 -#"ocean_model","PFu","PFu","mom","all",.true.,"none",2 -#"ocean_model","PFv","PFv","mom","all",.true.,"none",2 -#"ocean_model","du_dt_visc","du_dt_visc","mom","all",.true.,"none",2 -#"ocean_model","dv_dt_visc","dv_dt_visc","mom","all",.true.,"none",2 -#"ocean_model","diffu","diffu","mom","all",.true.,"none",2 -#"ocean_model","diffv","diffv","mom","all",.true.,"none",2 -#"ocean_model","dudt_dia","dudt_dia","mom","all",.true.,"none",2 -#"ocean_model","dvdt_dia","dvdt_dia","mom","all",.true.,"none",2 -# Subterms that should not be added to a closed budget. -#"ocean_model","gKEu","gKEu","mom","all",.true.,"none",2 -#"ocean_model","gKEv","gKEv","mom","all",.true.,"none",2 -#"ocean_model","rvxu","rvxu","mom","all",.true.,"none",2 -#"ocean_model","rvxv","rvxv","mom","all",.true.,"none",2 -#"ocean_model","PFu_bc","PFu_bc","mom","all",.true.,"none",2 -#"ocean_model","PFv_bc","PFv_bc","mom","all",.true.,"none",2 - -# Barotropic Momentum Balance Terms: -# (only available with split time stepping.) -#=========================================== -#"ocean_model","PFuBT","PFuBT","bt_mom","all",.true.,"none",2 -#"ocean_model","PFvBT","PFvBT","bt_mom","all",.true.,"none",2 -#"ocean_model","CoruBT","CoruBT","bt_mom","all",.true.,"none",2 -#"ocean_model","CorvBT","CorvBT","bt_mom","all",.true.,"none",2 -#"ocean_model","ubtforce","ubtforce","bt_mom","all",.true.,"none",2 -#"ocean_model","vbtforce","vbtforce","bt_mom","all",.true.,"none",2 -#"ocean_model","u_accel_bt","u_accel_bt","bt_mom","all",.true.,"none",2 -#"ocean_model","v_accel_bt","v_accel_bt","bt_mom","all",.true.,"none",2 -# -# Viscosities and diffusivities: -#=============================== -#"ocean_model","Kd_effective","Kd_effective","visc","all",.true.,"none",2 -#"ocean_model","Ahh","Ahh","visc","all",.true.,"none",2 -#"ocean_model","Ahq","Ahq","visc","all",.true.,"none",2 -#"ocean_model","Khh","Khh","visc","all",.true.,"none",2 -#"ocean_model","Khq","Khq","visc","all",.true.,"none",2 -#"ocean_model","bbl_thick_u","bbl_thick_u","visc","all",.true.,"none",2 -#"ocean_model","kv_bbl_u","kv_bbl_u","visc","all",.true.,"none",2 -#"ocean_model","bbl_thick_v","bbl_thick_v","visc","all",.true.,"none",2 -#"ocean_model","kv_bbl_v","kv_bbl_v","visc","all",.true.,"none",2 -#"ocean_model","av_visc","av_visc","visc","all",.true.,"none",2 -#"ocean_model","au_visc","au_visc","visc","all",.true.,"none",2 -# -# Kinetic Energy Balance Terms: -#============================= -#"ocean_model","KE","KE","energy","all",.true.,"none",2 -#"ocean_model","dKE_dt","dKE_dt","energy","all",.true.,"none",2 -#"ocean_model","PE_to_KE","PE_to_KE","energy","all",.true.,"none",2 -#"ocean_model","KE_Coradv","KE_Coradv","energy","all",.true.,"none",2 -#"ocean_model","KE_adv","KE_adv","energy","all",.true.,"none",2 -#"ocean_model","KE_visc","KE_visc","energy","all",.true.,"none",2 -#"ocean_model","KE_horvisc","KE_horvisc","energy","all",.true.,"none",2 -#"ocean_model","KE_dia","KE_dia","energy","all",.true.,"none",2 -# -# Mixed Layer TKE Budget Terms: -#=========================== -#"ocean_model","TKE_wind","TKE_wind","ML_TKE","all",.true.,"none",2 -#"ocean_model","TKE_RiBulk","TKE_RiBulk","ML_TKE","all",.true.,"none",2 -#"ocean_model","TKE_conv","TKE_conv","ML_TKE","all",.true.,"none",2 -#"ocean_model","TKE_pen_SW","TKE_pen_SW","ML_TKE","all",.true.,"none",2 -#"ocean_model","TKE_mixing","TKE_mixing","ML_TKE","all",.true.,"none",2 -#"ocean_model","TKE_mech_decay","TKE_mech_decay","ML_TKE","all",.true.,"none",2 -#"ocean_model","TKE_conv_decay","TKE_conv_decay","ML_TKE","all",.true.,"none",2 - -# Surface Forcing: -#================= -#"ocean_model","taux","taux","forcing","all",.true.,"none",2 -#"ocean_model","tauy","tauy","forcing","all",.true.,"none",2 -#"ocean_model","ustar","ustar","forcing","all",.true.,"none",2 -#"ocean_model","PRCmE","PRCmE","forcing","all",.true.,"none",2 -#"ocean_model","SW","SW","forcing","all",.true.,"none",2 -#"ocean_model","LwLatSens","LwLatSens","forcing","all",.true.,"none",2 -#"ocean_model","p_surf","p_surf","forcing","all",.true.,"none",2 -#"ocean_model","salt_flux","salt_flux","forcing","all",.true.,"none",2 -# - - -#============================================================================================= -# -#====> This file can be used with diag_manager/v2.0a (or higher) <==== -# -# -# FORMATS FOR FILE ENTRIES (not all input values are used) -# ------------------------ -# -#"file_name", output_freq, "output_units", format, "time_units", "time_long_name", ... -# (opt) new_file_frequecy, (opt) "new_file_freq_units", "new_file_start_date" -# -# -#output_freq: > 0 output frequency in "output_units" -# = 0 output frequency every time step -# =-1 output frequency at end of run -# -#output_units = units used for output frequency -# (years, months, days, minutes, hours, seconds) -# -#time_units = units used to label the time axis -# (days, minutes, hours, seconds) -# -# -# FORMAT FOR FIELD ENTRIES (not all input values are used) -# ------------------------ -# -#"module_name", "field_name", "output_name", "file_name" "time_sampling", time_avg, "other_opts", packing -# -#time_avg = .true. or .false. -# -#packing = 1 double precision -# = 2 float -# = 4 packed 16-bit integers -# = 8 packed 1-byte (not tested?) From c88ae758456063881e9acc1da150148267c76ca4 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 30 Aug 2019 20:34:08 +0000 Subject: [PATCH 026/259] Reduced size of tc3 for speed --- .testing/tc3/MOM_input | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 1689ef993e..430ce24b61 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -35,11 +35,11 @@ NJHALO = 4 ! default = 2 ! y-direction. With STATIC_MEMORY_ this is set as NJHALO_ ! in MOM_memory.h at compile time; without STATIC_MEMORY_ ! the default is NJHALO_ in MOM_memory.h (if defined) or 2. -NIGLOBAL = 25 ! +NIGLOBAL = 13 ! ! The total number of thickness grid points in the ! x-direction in the physical domain. With STATIC_MEMORY_ ! this is set in MOM_memory.h at compile time. -NJGLOBAL = 25 ! +NJGLOBAL = 13 ! ! The total number of thickness grid points in the ! y-direction in the physical domain. With STATIC_MEMORY_ ! this is set in MOM_memory.h at compile time. From a6e15995de02538c915d8cf8d99d9b4129f16458 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 30 Aug 2019 21:07:20 +0000 Subject: [PATCH 027/259] Added variant tc1.a --- .testing/Makefile | 2 +- .testing/tc1.a/MOM_input | 1 + .testing/tc1.a/MOM_override | 0 .testing/tc1.a/MOM_tc_variant | 1 + .testing/tc1.a/diag_table | 1 + .testing/tc1.a/input.nml | 20 ++++++++++++++++++++ 6 files changed, 24 insertions(+), 1 deletion(-) create mode 120000 .testing/tc1.a/MOM_input create mode 100644 .testing/tc1.a/MOM_override create mode 100644 .testing/tc1.a/MOM_tc_variant create mode 120000 .testing/tc1.a/diag_table create mode 100644 .testing/tc1.a/input.nml diff --git a/.testing/Makefile b/.testing/Makefile index 1dee0e2100..d3093bf523 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -37,7 +37,7 @@ MKMF_TEMPLATE ?= $(DEPS)/mkmf/templates/ncrc-gnu.mk # Executables BUILDS = symmetric asymmetric repro -CONFIGS := $(foreach n,$(shell seq 0 3),tc$(n)) +CONFIGS := $(wildcard tc*) TESTS = grids layouts restarts repros nans dims # The following variables are configured by Travis: diff --git a/.testing/tc1.a/MOM_input b/.testing/tc1.a/MOM_input new file mode 120000 index 0000000000..dca928737e --- /dev/null +++ b/.testing/tc1.a/MOM_input @@ -0,0 +1 @@ +../tc1/MOM_input \ No newline at end of file diff --git a/.testing/tc1.a/MOM_override b/.testing/tc1.a/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc1.a/MOM_tc_variant b/.testing/tc1.a/MOM_tc_variant new file mode 100644 index 0000000000..8032901a82 --- /dev/null +++ b/.testing/tc1.a/MOM_tc_variant @@ -0,0 +1 @@ +#override SPLIT=False diff --git a/.testing/tc1.a/diag_table b/.testing/tc1.a/diag_table new file mode 120000 index 0000000000..bf2ad677b6 --- /dev/null +++ b/.testing/tc1.a/diag_table @@ -0,0 +1 @@ +../tc1/diag_table \ No newline at end of file diff --git a/.testing/tc1.a/input.nml b/.testing/tc1.a/input.nml new file mode 100644 index 0000000000..3c7dcf7bea --- /dev/null +++ b/.testing/tc1.a/input.nml @@ -0,0 +1,20 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_tc_variant', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ From dfc2d0d80321d396f2a2e40baddc398d32350df9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 30 Aug 2019 17:20:47 -0400 Subject: [PATCH 028/259] Diagnostic dimensional scaling fixes This patch adds and fixes the scaling factors for several diagnostics. --- src/core/MOM_barotropic.F90 | 35 +++++++++++-------- src/diagnostics/MOM_diagnostics.F90 | 31 ++++++++-------- .../vertical/MOM_bulk_mixed_layer.F90 | 21 +++++------ .../vertical/MOM_vert_friction.F90 | 12 ++++--- 4 files changed, 55 insertions(+), 44 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 8d48ebbb0b..347b5a1936 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4205,13 +4205,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'Barotropic meridional acceleration from baroclinic terms', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, Time, & - 'Barotropic end SSH', thickness_units) + 'Barotropic end SSH', thickness_units, conversion=GV%H_to_m) CS%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, Time, & 'Barotropic end zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, Time, & 'Barotropic end meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, Time, & - 'Barotropic start SSH', thickness_units) + 'Barotropic start SSH', thickness_units, conversion=GV%H_to_m) CS%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, Time, & 'Barotropic start zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, Time, & @@ -4221,31 +4221,34 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, Time, & 'Barotropic time-average meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, Time, & - 'Corrective mass flux', 'm s-1') + 'Corrective mass flux', 'm s-1', conversion=GV%H_to_m) CS%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, Time, & 'Viscous remnant at u', 'nondim') CS%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, Time, & 'Viscous remnant at v', 'nondim') CS%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, Time, & - 'gtot to North', 'm s-2', conversion=US%L_T_to_m_s**2) + 'gtot to North', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, Time, & - 'gtot to South', 'm s-2', conversion=US%L_T_to_m_s**2) + 'gtot to South', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_gtote = register_diag_field('ocean_model', 'gtot_e', diag%axesT1, Time, & - 'gtot to East', 'm s-2', conversion=US%L_T_to_m_s**2) + 'gtot to East', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, Time, & - 'gtot to West', 'm s-2', conversion=US%L_T_to_m_s**2) + 'gtot to West', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, Time, & - 'High Frequency Barotropic SSH', thickness_units) + 'High Frequency Barotropic SSH', thickness_units, conversion=GV%H_to_m) CS%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, Time, & 'High Frequency Barotropic zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, Time, & 'High Frequency Barotropic meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, & - 'High Frequency Predictor Barotropic SSH', thickness_units) + 'High Frequency Predictor Barotropic SSH', thickness_units, & + conversion=GV%H_to_m) CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & - 'High Frequency Barotropic zonal transport', 'm3 s-1') + 'High Frequency Barotropic zonal transport', 'm3 s-1', & + conversion=GV%H_to_m*US%L_T_to_m_s) CS%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, Time, & - 'High Frequency Barotropic meridional transport', 'm3 s-1') + 'High Frequency Barotropic meridional transport', 'm3 s-1', & + conversion=GV%H_to_m*US%L_T_to_m_s) CS%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, Time, & 'Fractional thickness of layers in u-columns', 'nondim') CS%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, Time, & @@ -4255,9 +4258,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, Time, & 'Predictor Fractional thickness of layers in v-columns', 'nondim') CS%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, Time, & - 'Barotropic zonal transport averaged over a baroclinic step', 'm3 s-1') + 'Barotropic zonal transport averaged over a baroclinic step', 'm3 s-1', & + conversion=GV%H_to_m*US%L_T_to_m_s) CS%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, Time, & - 'Barotropic meridional transport averaged over a baroclinic step', 'm3 s-1') + 'Barotropic meridional transport averaged over a baroclinic step', 'm3 s-1', & + conversion=GV%H_to_m*US%L_T_to_m_s) if (use_BT_cont_type) then CS%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, Time, & @@ -4269,9 +4274,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_BTC_FA_u_W0 = register_diag_field('ocean_model', 'BTC_FA_u_W0', diag%axesCu1, Time, & 'BTCont type near west face area', 'm2', conversion=US%L_to_m*GV%H_to_m) CS%id_BTC_ubt_EE = register_diag_field('ocean_model', 'BTC_ubt_EE', diag%axesCu1, Time, & - 'BTCont type far east velocity', 'm s-1') + 'BTCont type far east velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, Time, & - 'BTCont type far west velocity', 'm s-1') + 'BTCont type far west velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, Time, & 'BTCont type far north face area', 'm2', conversion=US%L_to_m*GV%H_to_m) CS%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, Time, & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 54025a0ac0..f8f3ba2a56 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1495,7 +1495,8 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_thkcello = register_diag_field('ocean_model', 'thkcello', diag%axesTL, Time, & long_name = 'Cell Thickness', standard_name='cell_thickness', units='m', v_extensive=.true.) CS%id_h_pre_sync = register_diag_field('ocean_model', 'h_pre_sync', diag%axesTL, Time, & - long_name = 'Cell thickness from the previous timestep', units='m', v_extensive=.true.) + long_name = 'Cell thickness from the previous timestep', units='m', & + v_extensive=.true., conversion=GV%H_to_m) ! Note that CS%id_volcello would normally be registered here but because it is a "cell measure" and ! must be registered first. We earlier stored the handle of volcello but need it here for posting @@ -1832,10 +1833,10 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & - 'm s-1', v_extensive = .true.) + 'm s-1', v_extensive=.true., conversion=GV%H_to_m) IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & - 'm s-1', v_extensive = .true.) + 'm s-1', v_extensive=.true.) end subroutine register_transport_diags @@ -1882,34 +1883,34 @@ subroutine write_static_fields(G, GV, US, tv, diag) 'Longitude of zonal velocity (Cu) points', 'degrees_east', interp_method='none') if (id > 0) call post_data(id, G%geoLonCu, diag, .true.) - id = register_static_field('ocean_model', 'area_t', diag%axesT1, & - 'Surface area of tracer (T) cells', 'm2', conversion=US%m_to_L**2, & + id = register_static_field('ocean_model', 'area_t', diag%axesT1, & + 'Surface area of tracer (T) cells', 'm2', conversion=US%L_to_m**2, & cmor_field_name='areacello', cmor_standard_name='cell_area', & - cmor_long_name='Ocean Grid-Cell Area', & + cmor_long_name='Ocean Grid-Cell Area', & x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') if (id > 0) then call post_data(id, G%areaT, diag, .true.) call diag_register_area_ids(diag, id_area_t=id) endif - id = register_static_field('ocean_model', 'area_u', diag%axesCu1, & - 'Surface area of x-direction flow (U) cells', 'm2', conversion=US%m_to_L**2, & + id = register_static_field('ocean_model', 'area_u', diag%axesCu1, & + 'Surface area of x-direction flow (U) cells', 'm2', conversion=US%L_to_m**2, & cmor_field_name='areacello_cu', cmor_standard_name='cell_area', & - cmor_long_name='Ocean Grid-Cell Area', & + cmor_long_name='Ocean Grid-Cell Area', & x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') if (id > 0) call post_data(id, G%areaCu, diag, .true.) - id = register_static_field('ocean_model', 'area_v', diag%axesCv1, & - 'Surface area of y-direction flow (V) cells', 'm2', conversion=US%m_to_L**2, & + id = register_static_field('ocean_model', 'area_v', diag%axesCv1, & + 'Surface area of y-direction flow (V) cells', 'm2', conversion=US%L_to_m**2, & cmor_field_name='areacello_cv', cmor_standard_name='cell_area', & - cmor_long_name='Ocean Grid-Cell Area', & + cmor_long_name='Ocean Grid-Cell Area', & x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') if (id > 0) call post_data(id, G%areaCv, diag, .true.) - id = register_static_field('ocean_model', 'area_q', diag%axesB1, & - 'Surface area of B-grid flow (Q) cells', 'm2', conversion=US%m_to_L**2, & + id = register_static_field('ocean_model', 'area_q', diag%axesB1, & + 'Surface area of B-grid flow (Q) cells', 'm2', conversion=US%L_to_m**2, & cmor_field_name='areacello_bu', cmor_standard_name='cell_area', & - cmor_long_name='Ocean Grid-Cell Area', & + cmor_long_name='Ocean Grid-Cell Area', & x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') if (id > 0) call post_data(id, G%areaBu, diag, .true.) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index cbf42d2b8b..2a17bfbd6f 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3582,33 +3582,34 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) Time, 'Surface mixed layer depth', 'm') CS%id_TKE_wind = register_diag_field('ocean_model', 'TKE_wind', diag%axesT1, & Time, 'Wind-stirring source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_RiBulk = register_diag_field('ocean_model', 'TKE_RiBulk', diag%axesT1, & Time, 'Mean kinetic energy source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv = register_diag_field('ocean_model', 'TKE_conv', diag%axesT1, & - Time, 'Convective source of mixed layer TKE', 'm3 s-3', conversion=US%Z_to_m*US%T_to_s**3) + Time, 'Convective source of mixed layer TKE', 'm3 s-3', & + conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_pen_SW = register_diag_field('ocean_model', 'TKE_pen_SW', diag%axesT1, & Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mixing = register_diag_field('ocean_model', 'TKE_mixing', diag%axesT1, & Time, 'TKE consumed by mixing that deepens the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'TKE_mech_decay', diag%axesT1, & Time, 'Mechanical energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'TKE_conv_decay', diag%axesT1, & Time, 'Convective energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_s2 = register_diag_field('ocean_model', 'TKE_conv_s2', diag%axesT1, & Time, 'Spurious source of mixed layer TKE from sigma2', & - 'm3 s-3', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer detrainment', & - 'W m-2', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'W m-2', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain2 = register_diag_field('ocean_model', 'PE_detrain2', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer only detrainment', & - 'W m-2', conversion=US%Z_to_m*US%L_to_m**2*US%T_to_s**3) + 'W m-2', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_h_mismatch = register_diag_field('ocean_model', 'h_miss_ML', diag%axesT1, & Time, 'Summed absolute mismatch in entrainment terms', 'm', conversion=US%Z_to_m) CS%id_Hsfc_used = register_diag_field('ocean_model', 'Hs_used', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 1bed36e75e..b282995d3f 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1712,16 +1712,20 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & - 'Thickness at Zonal Velocity Points for Viscosity', thickness_units) + 'Thickness at Zonal Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & - 'Thickness at Meridional Velocity Points for Viscosity', thickness_units) + 'Thickness at Meridional Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & - 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units) + 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & - 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units) + 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units, & + conversion=GV%H_to_m) CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, & Time, 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) From 033bca26dbbb3b79dcabf5a72b755a5d2c252409 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 3 Sep 2019 17:35:20 -0400 Subject: [PATCH 029/259] Correct tendency scaling; update KE coversions This patch fixes an issue in the time scalings of the tendencies in MOM_diagnostics, where the timestep (dt) was not being scaled, and was only corrected in some of the variables. This patch also passes through the scaling of KE and dKE_dt onto the diagnostic conversion factors. --- src/diagnostics/MOM_diagnostics.F90 | 32 +++++++++++++++-------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index f8f3ba2a56..9fa7804b26 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -92,8 +92,8 @@ module MOM_diagnostics ! The following arrays hold diagnostics in the layer-integrated energy budget. real, pointer, dimension(:,:,:) :: & - KE => NULL(), & !< KE per unit mass [m2 s-2] - dKE_dt => NULL(), & !< time derivative of the layer KE [m3 s-3] + KE => NULL(), & !< KE per unit mass [L2 T-2 ~> m2 s-2] + dKE_dt => NULL(), & !< time derivative of the layer KE [H L2 T-3 ~> m3 s-3] PE_to_KE => NULL(), & !< potential energy to KE term [m3 s-3] KE_CorAdv => NULL(), & !< KE source from the combined Coriolis and advection terms [m3 s-3]. !! The Coriolis source should be zero, but is not due to truncation @@ -254,7 +254,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (loc(CS)==0) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") - call calculate_derivs(dt, G, CS) + call calculate_derivs(US%s_to_T*dt, G, CS) if (dt > 0.0) then call diag_save_grids(CS%diag) @@ -916,8 +916,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (associated(CS%KE)) then do k=1,nz ; do j=js,je ; do i=is,ie - CS%KE(i,j,k) = US%L_T_to_m_s**2*((u(I,j,k)*u(I,j,k) + u(I-1,j,k)*u(I-1,j,k)) + & - (v(i,J,k)*v(i,J,k) + v(i,J-1,k)*v(i,J-1,k)))*0.25 + CS%KE(i,j,k) = ((u(I,j,k) * u(I,j,k) + u(I-1,j,k) * u(I-1,j,k)) & + + (v(i,J,k) * v(i,J,k) + v(i,J-1,k) * v(i,J-1,k))) * 0.25 ! DELETE THE FOLLOWING... Make this 0 to test the momentum balance, ! or a huge number to test the continuity balance. ! CS%KE(i,j,k) *= 1e20 @@ -936,19 +936,19 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (associated(CS%dKE_dt)) then do k=1,nz do j=js,je ; do I=Isq,Ieq - KE_u(I,j) = US%L_T_to_m_s**2*US%s_to_T*uh(I,j,k)*G%dxCu(I,j)*CS%du_dt(I,j,k) + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * CS%du_dt(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*CS%dv_dt(i,J,k) + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * CS%dv_dt(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = CS%KE(i,j,k)*US%s_to_T*CS%dh_dt(i,j,k) + KE_h(i,j) = CS%KE(i,j,k) * CS%dh_dt(i,j,k) enddo ; enddo 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) = 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))) + 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)) enddo ; enddo enddo if (CS%id_dKEdt > 0) call post_data(CS%id_dKEdt, CS%dKE_dt, CS%diag) @@ -981,7 +981,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%CAv(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = -CS%KE(i,j,k) * G%IareaT(i,j) * & + KE_h(i,j) = -(US%L_T_to_m_s**2 * CS%KE(i,j,k)) * G%IareaT(i,j) * & US%s_to_T*(uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo if (.not.G%symmetric) & @@ -1009,7 +1009,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%gradKEv(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = -CS%KE(i,j,k) * G%IareaT(i,j) * & + KE_h(i,j) = -(US%L_T_to_m_s**2 * CS%KE(i,j,k)) * G%IareaT(i,j) * & US%s_to_T*(uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo if (.not.G%symmetric) & @@ -1067,7 +1067,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%dv_dt_dia(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = CS%KE(i,j,k) * & + KE_h(i,j) = (US%L_T_to_m_s**2 * CS%KE(i,j,k)) * & (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1)) enddo ; enddo if (.not.G%symmetric) & @@ -1626,11 +1626,13 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag ! terms in the kinetic energy budget CS%id_KE = register_diag_field('ocean_model', 'KE', diag%axesTL, Time, & - 'Layer kinetic energy per unit mass', 'm2 s-2') + 'Layer kinetic energy per unit mass', 'm2 s-2', & + conversion=US%L_T_to_m_s**2) if (CS%id_KE>0) call safe_alloc_ptr(CS%KE,isd,ied,jsd,jed,nz) CS%id_dKEdt = register_diag_field('ocean_model', 'dKE_dt', diag%axesTL, Time, & - 'Kinetic Energy Tendency of Layer', 'm3 s-3') + 'Kinetic Energy Tendency of Layer', 'm3 s-3', & + conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_dKEdt>0) call safe_alloc_ptr(CS%dKE_dt,isd,ied,jsd,jed,nz) CS%id_PE_to_KE = register_diag_field('ocean_model', 'PE_to_KE', diag%axesTL, Time, & From 8965e7111eea675d28b3afc9d381ea84e3f7631e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 4 Sep 2019 10:59:52 -0400 Subject: [PATCH 030/259] More KE tendency dimensional scaling Finished the rescaling of the layer KE tendency diagnostics, which are all now passing the diagnostic checksum scaling tests. --- src/diagnostics/MOM_diagnostics.F90 | 89 ++++++++++++++++------------- 1 file changed, 48 insertions(+), 41 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 9fa7804b26..4aa6fad710 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -95,14 +95,15 @@ module MOM_diagnostics KE => NULL(), & !< KE per unit mass [L2 T-2 ~> m2 s-2] dKE_dt => NULL(), & !< time derivative of the layer KE [H L2 T-3 ~> m3 s-3] PE_to_KE => NULL(), & !< potential energy to KE term [m3 s-3] - KE_CorAdv => NULL(), & !< KE source from the combined Coriolis and advection terms [m3 s-3]. + KE_CorAdv => NULL(), & !< KE source from the combined Coriolis and + !! advection terms [H L2 T-3 ~> m3 s-3]. !! The Coriolis source should be zero, but is not due to truncation !! errors. There should be near-cancellation of the global integral !! of this spurious Coriolis source. - KE_adv => NULL(), & !< KE source from along-layer advection [m3 s-3] - KE_visc => NULL(), & !< KE source from vertical viscosity [m3 s-3] - KE_horvisc => NULL(), & !< KE source from horizontal viscosity [m3 s-3] - KE_dia => NULL() !< KE source from diapycnal diffusion [m3 s-3] + KE_adv => NULL(), & !< KE source from along-layer advection [H L2 T-3 ~> m3 s-3] + KE_visc => NULL(), & !< KE source from vertical viscosity [H L2 T-3 ~> m3 s-3] + KE_horvisc => NULL(), & !< KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3] + KE_dia => NULL() !< KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3] !>@{ Diagnostic IDs integer :: id_u = -1, id_v = -1, id_h = -1 @@ -957,16 +958,16 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (associated(CS%PE_to_KE)) then do k=1,nz do j=js,je ; do I=Isq,Ieq - KE_u(I,j) = US%L_T_to_m_s**2*US%s_to_T*uh(I,j,k)*G%dxCu(I,j)*ADp%PFu(I,j,k) + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%PFu(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%PFv(i,J,k) + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%PFv(i,J,k) enddo ; enddo 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) = 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)) + CS%PE_to_KE(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)) enddo ; enddo enddo if (CS%id_PE_to_KE > 0) call post_data(CS%id_PE_to_KE, CS%PE_to_KE, CS%diag) @@ -975,20 +976,20 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (associated(CS%KE_CorAdv)) then do k=1,nz do j=js,je ; do I=Isq,Ieq - KE_u(I,j) = US%L_T_to_m_s**2*US%s_to_T*uh(I,j,k)*G%dxCu(I,j)*ADp%CAu(I,j,k) + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%CAu(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%CAv(i,J,k) + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%CAv(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = -(US%L_T_to_m_s**2 * CS%KE(i,j,k)) * G%IareaT(i,j) * & - US%s_to_T*(uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + KE_h(i,j) = -CS%KE(i,j,k) * G%IareaT(i,j) & + * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo 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) = 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))) + 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)) enddo ; enddo enddo if (CS%id_KE_Coradv > 0) call post_data(CS%id_KE_Coradv, CS%KE_Coradv, CS%diag) @@ -1002,21 +1003,21 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS do k=1,nz do j=js,je ; do I=Isq,Ieq if (G%mask2dCu(i,j) /= 0.) & - KE_u(I,j) = US%L_T_to_m_s**2*US%s_to_T*uh(I,j,k)*G%dxCu(I,j)*ADp%gradKEu(I,j,k) + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%gradKEu(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie if (G%mask2dCv(i,j) /= 0.) & - KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%gradKEv(i,J,k) + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%gradKEv(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = -(US%L_T_to_m_s**2 * CS%KE(i,j,k)) * G%IareaT(i,j) * & - US%s_to_T*(uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + KE_h(i,j) = -CS%KE(i,j,k) * G%IareaT(i,j) & + * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo 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) = 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))) + 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)) enddo ; enddo enddo if (CS%id_KE_adv > 0) call post_data(CS%id_KE_adv, CS%KE_adv, CS%diag) @@ -1025,16 +1026,16 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (associated(CS%KE_visc)) then do k=1,nz do j=js,je ; do I=Isq,Ieq - KE_u(I,j) = US%L_T_to_m_s**2*US%s_to_T*uh(I,j,k)*G%dxCu(I,j)*ADp%du_dt_visc(I,j,k) + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%dv_dt_visc(i,J,k) + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_visc(i,J,k) enddo ; enddo 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) = 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))) + 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)) enddo ; enddo enddo if (CS%id_KE_visc > 0) call post_data(CS%id_KE_visc, CS%KE_visc, CS%diag) @@ -1043,16 +1044,16 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (associated(CS%KE_horvisc)) then do k=1,nz do j=js,je ; do I=Isq,Ieq - KE_u(I,j) = US%s_to_T*uh(I,j,k)*US%L_to_m*G%dxCu(I,j)*US%L_T2_to_m_s2*ADp%diffu(I,j,k) + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%diffu(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - KE_v(i,J) = US%s_to_T*vh(i,J,k)*US%L_to_m*G%dyCv(i,J)*US%L_T2_to_m_s2*ADp%diffv(i,J,k) + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%diffv(i,J,k) enddo ; enddo 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) = 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)) + CS%KE_horvisc(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)) enddo ; enddo enddo if (CS%id_KE_horvisc > 0) call post_data(CS%id_KE_horvisc, CS%KE_horvisc, CS%diag) @@ -1061,20 +1062,20 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (associated(CS%KE_dia)) then do k=1,nz do j=js,je ; do I=Isq,Ieq - KE_u(I,j) = US%L_T_to_m_s**2*US%s_to_T*uh(I,j,k)*G%dxCu(I,j)*ADp%du_dt_dia(I,j,k) + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_dia(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - KE_v(i,J) = US%L_T_to_m_s**2*US%s_to_T*vh(i,J,k)*G%dyCv(i,J)*ADp%dv_dt_dia(i,J,k) + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_dia(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - KE_h(i,j) = (US%L_T_to_m_s**2 * CS%KE(i,j,k)) * & - (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1)) + KE_h(i,j) = CS%KE(i,j,k) & + * (US%T_to_s * (CDp%diapyc_vel(i,j,k) - CDp%diapyc_vel(i,j,k+1))) enddo ; enddo 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) + 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)) + CS%KE_dia(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)) enddo ; enddo enddo if (CS%id_KE_dia > 0) call post_data(CS%id_KE_dia, CS%KE_dia, CS%diag) @@ -1636,28 +1637,34 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag if (CS%id_dKEdt>0) call safe_alloc_ptr(CS%dKE_dt,isd,ied,jsd,jed,nz) CS%id_PE_to_KE = register_diag_field('ocean_model', 'PE_to_KE', diag%axesTL, Time, & - 'Potential to Kinetic Energy Conversion of Layer', 'm3 s-3') + 'Potential to Kinetic Energy Conversion of Layer', 'm3 s-3', & + conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_PE_to_KE>0) call safe_alloc_ptr(CS%PE_to_KE,isd,ied,jsd,jed,nz) CS%id_KE_Coradv = register_diag_field('ocean_model', 'KE_Coradv', diag%axesTL, Time, & - 'Kinetic Energy Source from Coriolis and Advection', 'm3 s-3') + 'Kinetic Energy Source from Coriolis and Advection', 'm3 s-3', & + conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_Coradv>0) call safe_alloc_ptr(CS%KE_Coradv,isd,ied,jsd,jed,nz) CS%id_KE_adv = register_diag_field('ocean_model', 'KE_adv', diag%axesTL, Time, & - 'Kinetic Energy Source from Advection', 'm3 s-3') + 'Kinetic Energy Source from Advection', 'm3 s-3', & + conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_adv>0) call safe_alloc_ptr(CS%KE_adv,isd,ied,jsd,jed,nz) CS%id_KE_visc = register_diag_field('ocean_model', 'KE_visc', diag%axesTL, Time, & - 'Kinetic Energy Source from Vertical Viscosity and Stresses', 'm3 s-3') + 'Kinetic Energy Source from Vertical Viscosity and Stresses', 'm3 s-3', & + conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_visc>0) call safe_alloc_ptr(CS%KE_visc,isd,ied,jsd,jed,nz) CS%id_KE_horvisc = register_diag_field('ocean_model', 'KE_horvisc', diag%axesTL, Time, & - 'Kinetic Energy Source from Horizontal Viscosity', 'm3 s-3') + 'Kinetic Energy Source from Horizontal Viscosity', 'm3 s-3', & + conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_horvisc>0) call safe_alloc_ptr(CS%KE_horvisc,isd,ied,jsd,jed,nz) if (.not. adiabatic) then CS%id_KE_dia = register_diag_field('ocean_model', 'KE_dia', diag%axesTL, Time, & - 'Kinetic Energy Source from Diapycnal Diffusion', 'm3 s-3') + 'Kinetic Energy Source from Diapycnal Diffusion', 'm3 s-3', & + conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_dia>0) call safe_alloc_ptr(CS%KE_dia,isd,ied,jsd,jed,nz) endif From 95a677951797aee6db81657bf9ac7b9176e93a7e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 4 Sep 2019 11:28:09 -0400 Subject: [PATCH 031/259] Barotropic transport diagnostic scaling This patch fixes the scaling of the diagnostic parameters in the [uv]hbt and [uv]hbt_hifreq transport diagnostics. --- src/core/MOM_barotropic.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 347b5a1936..7b2f367487 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4245,10 +4245,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, conversion=GV%H_to_m) CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & 'High Frequency Barotropic zonal transport', 'm3 s-1', & - conversion=GV%H_to_m*US%L_T_to_m_s) + conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, Time, & 'High Frequency Barotropic meridional transport', 'm3 s-1', & - conversion=GV%H_to_m*US%L_T_to_m_s) + conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, Time, & 'Fractional thickness of layers in u-columns', 'nondim') CS%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, Time, & @@ -4259,10 +4259,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'Predictor Fractional thickness of layers in v-columns', 'nondim') CS%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, Time, & 'Barotropic zonal transport averaged over a baroclinic step', 'm3 s-1', & - conversion=GV%H_to_m*US%L_T_to_m_s) + conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) CS%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, Time, & 'Barotropic meridional transport averaged over a baroclinic step', 'm3 s-1', & - conversion=GV%H_to_m*US%L_T_to_m_s) + conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) if (use_BT_cont_type) then CS%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, Time, & From 833ad4637c0efbe3f1e0fa17bb63d3b90c5fe4b8 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 4 Sep 2019 14:02:40 -0400 Subject: [PATCH 032/259] Diagnostic global average dimensional fix Length scaling for global averaging is no longer required and has been removed. This has fixed the dimensional scaling of any diagnostics using this function. --- 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 f7084ee7ea..f6282faa52 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -35,8 +35,8 @@ function global_area_mean(var,G) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec tmpForSumming(:,:) = 0. - do j=js,je ; do i=is, ie - tmpForSumming(i,j) = ( var(i,j) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) ) + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo global_area_mean = reproducing_sum( tmpForSumming ) * G%IareaT_global From 5937da2a02b4961c53dbaa8f0b8f9aa1de22ba5f Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 4 Sep 2019 13:41:31 -0600 Subject: [PATCH 033/259] Add additional sanity checks in neutral diffusion and add option to avoid doing ALE reconstructions in the main driver --- src/core/MOM.F90 | 6 +++++- src/tracer/MOM_neutral_diffusion.F90 | 4 ++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b2d211796f..357bc799c4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -210,6 +210,7 @@ module MOM logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode + logical :: do_remap type(time_type), pointer :: Time !< pointer to the ocean clock real :: dt !< (baroclinic) dynamics time step (seconds) @@ -1204,7 +1205,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Regridding/remapping is done here, at end of thermodynamics time step ! (that may comprise several dynamical time steps) ! The routine 'ALE_main' can be found in 'MOM_ALE.F90'. - if ( CS%use_ALE_algorithm ) then + if ( CS%use_ALE_algorithm .and. CS%do_remap ) then call enable_averaging(dtdia, Time_end_thermo, CS%diag) ! call pass_vector(u, v, G%Domain) if (associated(tv%T)) & @@ -1710,6 +1711,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & "If True, use the ALE algorithm (regridding/remapping).\n"//& "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, "MOM", "DO_REMAP", CS%do_remap, & + "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If False, use the layered isopycnal algorithm.", default=.true. ) call get_param(param_file, "MOM", "BULKMIXEDLAYER", bulkmixedlayer, & "If true, use a Kraus-Turner-like bulk mixed layer \n"//& "with transitional buffer layers. Layers 1 through \n"//& diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index fd8d6264a0..91ea6f5891 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1548,8 +1548,8 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly return endif if ( SIGN(1.,drho_b) == SIGN(1.,drho_c) ) then - print *, drho_b, drho_c - call MOM_error(WARNING, "drho_b is the same sign as dhro_c") +! print *, drho_b, drho_c +! call MOM_error(WARNING, "drho_b is the same sign as dhro_c") z = z0 return endif From 89b736fd28ea9ed81337204b7595213d5ef28e62 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 4 Sep 2019 16:35:18 -0400 Subject: [PATCH 034/259] (+) Tracer diffusive flux diagnostic scaling Diagnostics of diffusive tracer fluxes (*_diff[xy], *_diff[xy]_2d) were not scaling due to issues with the Coef_x term, which was in units of L2 while the tracer itself was in units of m2. Although the Coef_x term was being de-scaled to meters, the cumulative sum was failing to reproduce for many tracers, either being reverted (in temp) or failing to reproduce all bits (in salt). We resolve this by re-defining the diffusive flux terms as H L2 s-1, rather than H m2 s-1, and moving the scaling to the final conversion factor, which restored reproducibility of all tracers. This patch contains an API change. We have added the unit scaling struct (US) to the register_tracer_diagnostic function. --- src/core/MOM.F90 | 2 +- src/tracer/MOM_tracer_hor_diff.F90 | 16 ++++++++-------- src/tracer/MOM_tracer_registry.F90 | 30 +++++++++++++++++++----------- 3 files changed, 28 insertions(+), 20 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 23c11cc05b..8a5f9bfe02 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2371,7 +2371,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_surface_diags(Time, G, CS%sfc_IDs, CS%diag, CS%tv) call register_diags(Time, G, GV, US, CS%IDs, CS%diag) call register_transport_diags(Time, G, GV, US, CS%transport_IDs, CS%diag) - 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, US, & CS%use_ALE_algorithm) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 098a647ec8..5577115a48 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -449,20 +449,20 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online Coef_y(i,J) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) enddo ; enddo if (associated(Reg%Tr(m)%df_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + US%L_to_m**2*Coef_x(I,j) * & - (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))*Idt + Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + US%L_to_m**2*Coef_y(i,J) * & - (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k))*Idt + Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + US%L_to_m**2*Coef_x(I,j) * & - (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))*Idt + Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + US%L_to_m**2*Coef_y(i,J) * & - (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k))*Idt + Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J) & + * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif do j=js,je ; do i=is,ie Reg%Tr(m)%t(i,j,k) = Reg%Tr(m)%t(i,j,k) + dTr(i,j) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 4680c058b4..41299be3e8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -20,6 +20,7 @@ module MOM_tracer_registry 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_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -53,13 +54,13 @@ module MOM_tracer_registry !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux @@ -320,9 +321,10 @@ end subroutine lock_tracer_registry !> 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) +subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses @@ -396,10 +398,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) 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), v_extensive = .true., y_cell_method = 'sum') + trim(flux_units), v_extensive = .true., conversion=US%L_to_m**2, & + 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), v_extensive = .true., x_cell_method = 'sum') + trim(flux_units), v_extensive = .true., conversion=US%L_to_m**2, & + 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), & @@ -409,10 +413,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) 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, y_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*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, x_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*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) @@ -430,11 +436,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, use_ALE) 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, y_cell_method = 'sum') + flux_units, conversion=(US%L_to_m**2)*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, x_cell_method = 'sum') + flux_units, conversion=(US%L_to_m**2)*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) From 648c5b113fe8d30ef8a9e8eae9466c72b32c9c49 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 4 Sep 2019 17:02:42 -0600 Subject: [PATCH 035/259] Fix doxygen errors in neutral_diffusion and EOS modules - MOM_EOS.F90: enclose units in [ ], comment compressibility - MOM_neutral_diffusion.F90: Add escape commands for Latex --- src/equation_of_state/MOM_EOS.F90 | 19 ++++++++++--------- src/tracer/MOM_neutral_diffusion.F90 | 9 +++++---- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index d80d619a10..0b966e8549 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -82,6 +82,7 @@ module MOM_EOS module procedure calculate_TFreeze_scalar, calculate_TFreeze_array end interface calculate_TFreeze +!> Calculates the compressibility of water from T, S, and P interface calculate_compress module procedure calculate_compress_scalar, calculate_compress_array end interface calculate_compress @@ -528,15 +529,15 @@ end subroutine calculate_specific_vol_derivs !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, EOS) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, dimension(:), intent(in) :: S !< Salinity (PSU) - real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: rho !< In situ density in kg m-3. - real, dimension(:), intent(out) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) in s2 m-2. - integer, intent(in) :: start !< Starting index within the array - integer, intent(in) :: npts !< The number of values to calculate - type(EOS_type), pointer :: EOS !< Equation of state structure + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3]. + real, dimension(:), intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) [s2 m-2]. + integer, intent(in) :: start !< Starting index within the array + integer, intent(in) :: npts !< The number of values to calculate + type(EOS_type), pointer :: EOS !< Equation of state structure if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_compress called with an unassociated EOS_type EOS.") diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 7348cbeabc..58dee6eec1 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -79,7 +79,8 @@ module MOM_neutral_diffusion type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. integer :: neutral_pos_method !< Method to find the position of a neutral surface within the layer - character(len=40) :: delta_rho_form + character(len=40) :: delta_rho_form !< Determine which (if any) approximation is made to the + !! equation describing the difference in density integer :: id_uhEff_2d = -1 !< Diagnostic IDs integer :: id_vhEff_2d = -1 !< Diagnostic IDs @@ -1652,9 +1653,9 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, end subroutine calc_delta_rho_and_derivs !> Calculate delta rho from derivatives and gradients of properties -!! $\Delta \rho$ = \frac{1}{2}\left[ (\alpha_1 + \alpha_2)*(T_1-T_2) + +!! \f$ \Delta \rho$ = \frac{1}{2}\left[ (\alpha_1 + \alpha_2)*(T_1-T_2) + !! (\beta_1 + \beta_2)*(S_1-S_2) + -!! (\gamma^{-1}_1 + \gamma%{-1}_2)*(P_1-P_2) \right] +!! (\gamma^{-1}_1 + \gamma%{-1}_2)*(P_1-P_2) \right] \f$ function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, & T2, S2, P2, dRdT2, dRdS2 ) result (drho) real :: T1 !< Temperature at point 1 @@ -1670,7 +1671,7 @@ function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, & ! Local variables real :: drho - drho = 0.5 * ( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2 )) + drho = 0.5 * ( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2)) end function delta_rho_from_derivs !> Converts non-dimensional position within a layer to absolute position (for debugging) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 6e842ce35a..4dea5bbb89 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -58,7 +58,7 @@ module MOM_tracer_hor_diff logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within !! tracer_hor_diff. logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been - !! exceeded + !! exceeded type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. From 70362368702df81050dd4796a2008e47edd43fcb Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 5 Sep 2019 12:01:20 -0400 Subject: [PATCH 036/259] Dimensional scaling of MEKE_src Dimensional scaling factor was added to the MEKE_src diagnostic, fixing the rescaling reproducibility. --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index d204db1305..6c038a4eb5 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1148,7 +1148,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) 'MEKE derived barotropic eddy-velocity scale', 'm s-1', conversion=US%L_T_to_m_s) if (.not. associated(MEKE%MEKE)) CS%id_Ut = -1 CS%id_src = register_diag_field('ocean_model', 'MEKE_src', diag%axesT1, Time, & - 'MEKE energy source', 'm2 s-3') + 'MEKE energy source', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & 'MEKE decay rate', 's-1', conversion=US%s_to_T) CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & From 5024d44be26c0dd97db554bc9372f38cf87534ad Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 5 Sep 2019 08:47:31 -0600 Subject: [PATCH 037/259] Remove redundant DO_REMAP runtime setting USE_REGRIDDING essentially served the same purpose. Could not revert the commit that added this because it was folded into a larger commit (oops) --- src/core/MOM.F90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 6d7e6cf2da..23c11cc05b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -212,7 +212,6 @@ module MOM logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode - logical :: do_remap type(time_type), pointer :: Time !< pointer to the ocean clock real :: dt !< (baroclinic) dynamics time step [s] @@ -1201,7 +1200,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Regridding/remapping is done here, at end of thermodynamics time step ! (that may comprise several dynamical time steps) ! The routine 'ALE_main' can be found in 'MOM_ALE.F90'. - if ( CS%use_ALE_algorithm .and. CS%do_remap ) then + if ( CS%use_ALE_algorithm ) then call enable_averaging(dtdia, Time_end_thermo, CS%diag) ! call pass_vector(u, v, G%Domain) if (associated(tv%T)) & @@ -1702,9 +1701,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) - call get_param(param_file, "MOM", "DO_REMAP", CS%do_remap, & - "If True, use the ALE algorithm (regridding/remapping).\n"//& - "If False, use the layered isopycnal algorithm.", default=.true. ) call get_param(param_file, "MOM", "BULKMIXEDLAYER", bulkmixedlayer, & "If true, use a Kraus-Turner-like bulk mixed layer "//& "with transitional buffer layers. Layers 1 through "//& From 95eaf73cca495c2904fd1eef5e1d5dfb40f802e7 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 5 Sep 2019 08:50:06 -0600 Subject: [PATCH 038/259] Update DO_DYNAMICS runtime description/logging DO_DYNAMICS was previously a 'do_not_log' parameter. However, there are regression test cases (e.g. neutral diffusion) that do use this flag. This commit enables the automatic logging of the parameter, but modifies the description to alert users that it's primary use is for development --- src/core/MOM.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 23c11cc05b..0003f8ab69 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1674,8 +1674,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "faster by eliminating subroutine calls.", default=.false.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & "If False, skips the dynamics calls that update u & v, as well as "//& - "the gravity wave adjustment to h. This is a fragile feature and "//& - "thus undocumented.", default=.true., do_not_log=.true. ) + "the gravity wave adjustment to h. This may be a fragile feature, "//& + "but can be useful during development", default=.true.) call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & "If True, advect temperature and salinity horizontally "//& "If False, T/S are registered for advection. "//& From dc18786197585f3bac6e72e9e83a243844cc087a Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 5 Sep 2019 14:10:38 -0400 Subject: [PATCH 039/259] Travis: Output stderr on fail Stderr for a test is currently saved to the debug.out file, for future potential parsing. We now print this output to stdout if a test case fails in order to help troubleshooting any failed Travis jobs. --- .testing/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index d3093bf523..207582e4dc 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -222,7 +222,8 @@ $$(BASE)/.testing/%/ocean.stats.$(1): $$(BUILD)/$(2)/MOM6 if [ $(3) ]; then find $$(BUILD) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D)/RESTART echo $(4) > $$(@D)/MOM_override - cd $$(@D) && $$(call MPIRUN_CMD,$(5)) -n $(6) $$< 2> debug.out + cd $$(@D) && $$(call MPIRUN_CMD,$(5)) -n $(6) $$< 2> debug.out \ + || ! cat debug.out cp $$(@D)/ocean.stats $$@ > $$(@D)/MOM_override if [ $(3) ]; then cd $$(BASE) && bash <(curl -s https://codecov.io/bash) -n $$@; fi From d64b472f519611ae5f4e03b5f6d5ccc4e1af7d38 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 5 Sep 2019 15:31:03 -0400 Subject: [PATCH 040/259] Unsplit timestep diag fixes (CAu, etc) This patch fixes a bug in the registration of CAu, where the conversion argument had been included in the string of the dimensions of the diagnostic registration. The units of various accelerations have also been changed from 'meter second-2' to 'm s-2' for consistent with the rest of the model. --- src/core/MOM_dynamics_unsplit.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 108f4c8943..9e8be65d7a 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -678,13 +678,17 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS 'Meridional Thickness Flux', flux_units, x_cell_method='sum', v_extensive=.true., & conversion=H_convert*US%L_to_m**2*US%s_to_T) CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & - 'Zonal Coriolis and Advective Acceleration', 'meter second-2, conversion=US%L_T2_to_m_s2') + 'Zonal Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & - 'Meridional Coriolis and Advective Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) + 'Meridional Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & - 'Zonal Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) + 'Zonal Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & - 'Meridional Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) + 'Meridional Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) From 453f8594f38ceac5de5934ad946d6ed882edcc3d Mon Sep 17 00:00:00 2001 From: William Cooke Date: Thu, 5 Sep 2019 16:51:54 -0400 Subject: [PATCH 041/259] Update to prevent divide by zero in future version of mstar Also standardizing capitalization of names of some variables (MStar vs mstar) --- .../vertical/MOM_energetic_PBL.F90 | 32 +++++++++++-------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index b486e1e2ca..5527866793 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1772,16 +1772,16 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& if (CS%answers_2018) then ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) - MStar_S = CS%MStar_coef*sqrt(max(0.0,Buoyancy_Flux) / Ustar**2 / & + MStar_S = CS%MStar_coef*sqrt(max(0.0,Buoyancy_Flux) / UStar**2 / & (Abs_Coriolis + 1.e-10*US%T_to_s) ) ! The limit for rotation (Ekman length) limited mixing - MStar_N = CS%C_Ek * log( max( 1., Ustar / (Abs_Coriolis + 1.e-10*US%T_to_s) / BLD ) ) + MStar_N = CS%C_Ek * log( max( 1., UStar / (Abs_Coriolis + 1.e-10*US%T_to_s) / BLD ) ) else ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) - mstar_S = CS%MSTAR_COEF*sqrt(max(0.0, Buoyancy_Flux) / (Ustar**2 * max(Abs_Coriolis, 1.e-20*US%T_to_s))) + MStar_S = CS%MSTAR_COEF*sqrt(max(0.0, Buoyancy_Flux) / (UStar**2 * max(Abs_Coriolis, 1.e-20*US%T_to_s))) ! The limit for rotation (Ekman length) limited mixing - mstar_N = 0.0 - if (Ustar > Abs_Coriolis * BLD) mstar_N = CS%C_EK * log(Ustar / (Abs_Coriolis * BLD)) + MStar_N = 0.0 + if (UStar > Abs_Coriolis * BLD) Mstar_N = CS%C_EK * log(UStar / (Abs_Coriolis * BLD)) endif ! Here 1.25 is about .5/von Karman, which gives the Obukhov limit. @@ -1792,11 +1792,11 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& MStar_N = CS%RH18_MStar_cn1 * ( 1.0 - 1.0 / ( 1. + CS%RH18_MStar_cn2 * & exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) ) ) else - MSN_term = CS%RH18_MStar_cn2 * exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / Ustar) + MSN_term = CS%RH18_MStar_cn2 * exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) MStar_N = (CS%RH18_MStar_cn1 * MSN_term) / ( 1. + MSN_term) endif MStar_S = CS%RH18_MStar_CS1 * ( max(0.0, Buoyancy_Flux)**2 * BLD / & - ( Ustar**5 * max(Abs_Coriolis,1.e-20*US%T_to_s) ) )**CS%RH18_mstar_cs2 + ( UStar**5 * max(Abs_Coriolis,1.e-20*US%T_to_s) ) )**CS%RH18_mstar_cs2 MStar = MStar_N + MStar_S endif @@ -1804,11 +1804,15 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& if (CS%answers_2018) then MStar_Conv_Red = 1. - CS%MStar_Convect_coef * (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) / & ( (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) + & - 2.0 *MStar * Ustar**3 / BLD ) + 2.0 *MStar * UStar**3 / BLD ) else MSCR_term1 = -BLD * min(0.0, Buoyancy_Flux) - MSCR_term2 = 2.0*MStar * Ustar**3 - MStar_Conv_Red = ((1.-CS%mstar_convect_coef) * MSCR_term1 + MSCR_term2) / (MSCR_term1 + MSCR_term2) + MSCR_term2 = 2.0*MStar * UStar**3 + if ( abs(MSCR_term2) > 0.0) then + MStar_Conv_Red = ((1.-CS%mstar_convect_coef) * MSCR_term1 + MSCR_term2) / (MSCR_term1 + MSCR_term2) + else + MStar_Conv_Red = 1.-CS%mstar_convect_coef + endif endif !/3. Combine various mstar terms to get final value @@ -1816,15 +1820,15 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& if (present(Langmuir_Number)) then !### In this call, ustar was previously ustar_mean. Is this change deliberate? - call mstar_Langmuir(CS, US, abs_Coriolis, buoyancy_flux, ustar, BLD, Langmuir_number, mstar, & - mstar_LT, Convect_Langmuir_Number) + call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, MStar, & + MStar_LT, Convect_Langmuir_Number) endif end subroutine Find_Mstar !> This subroutine modifies the Mstar value if the Langmuir number is present -subroutine Mstar_Langmuir(CS, US, abs_Coriolis, buoyancy_flux, ustar, BLD, Langmuir_Number, & - mstar, mstar_LT, Convect_Langmuir_Number) +subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, & + Mstar, MStar_LT, Convect_Langmuir_Number) type(energetic_PBL_CS), pointer :: CS !< Energetic_PBL control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: Abs_Coriolis !< Absolute value of the Coriolis parameter [T-1 ~> s-1] From c58e875733e2da346ee88d2e6d75f1735815ba9f Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 14 Aug 2019 15:43:48 -0800 Subject: [PATCH 042/259] First stab at taking out time-filter from OBC --- src/core/MOM_open_boundary.F90 | 476 ++++++++++++++++++++++----------- 1 file changed, 325 insertions(+), 151 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index dbdc0b72c1..63e7b26a61 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -216,6 +216,7 @@ module MOM_open_boundary !! for input from user directory. logical :: update_OBC = .false. !< Is OBC data time-dependent logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs + logical :: time_filter !< If true, apply time filtering to phase speed. logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the relative vorticity on open boundaries. @@ -381,10 +382,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& "viscosity term.", default=.false.) + call get_param(param_file, mdl, "OBC_TIME_FILTER", OBC%time_filter, & + "If true, apply a time filter to the calculation of the phase speed at the"//& + "boundary.", default=.true.) call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & "If true, set the areas outside open boundaries to be land.", & default=.false.) - call get_param(param_file, mdl, "DEBUG", debug, default=.false.) call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) if (debug_OBC .or. debug) & @@ -1653,44 +1656,46 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) !! Copy previously calculated phase velocity from global arrays into segments !! This is terribly inefficient and temporary solution for continuity across restarts !! and needs to be revisited in the future. - do n=1,OBC%number_of_segments - segment=>OBC%segment(n) - if (.not. segment%on_pe) cycle - if (segment%is_E_or_W .and. segment%radiation) then - do k=1,G%ke - I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) + if (OBC%time_filter) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + if (segment%is_E_or_W .and. segment%radiation) then + do k=1,G%ke + 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 - enddo - elseif (segment%is_N_or_S .and. segment%radiation) then - do k=1,G%ke - J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + elseif (segment%is_N_or_S .and. segment%radiation) then + do k=1,G%ke + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + enddo enddo - enddo - endif - if (segment%is_E_or_W .and. segment%oblique) then - do k=1,G%ke - I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) - segment%ry_normal(I,j,k) = OBC%ry_normal(I,j,k) - segment%cff_normal(I,j,k) = OBC%cff_normal(I,j,k) + endif + if (segment%is_E_or_W .and. segment%oblique) then + do k=1,G%ke + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) + segment%ry_normal(I,j,k) = OBC%ry_normal(I,j,k) + segment%cff_normal(I,j,k) = OBC%cff_normal(I,j,k) + enddo enddo - enddo - elseif (segment%is_N_or_S .and. segment%oblique) then - do k=1,G%ke - J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - segment%rx_normal(i,J,k) = OBC%rx_normal(i,J,k) - segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) - segment%cff_normal(i,J,k) = OBC%cff_normal(i,J,k) + elseif (segment%is_N_or_S .and. segment%oblique) then + do k=1,G%ke + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + segment%rx_normal(i,J,k) = OBC%rx_normal(i,J,k) + segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%cff_normal(i,J,k) = OBC%cff_normal(i,J,k) + enddo enddo - enddo - endif - enddo + endif + enddo + endif gamma_u = OBC%gamma_uv ; gamma_v = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max @@ -1707,7 +1712,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = (u_new(I-1,j,k) - u_new(I-2,j,k)) !in new time backward sasha for I-1 rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + if (OBC%time_filter) then + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + else + rx_avg = rx_new + endif segment%rx_normal(I,j,k) = rx_avg ! The new boundary value is interpolated between future interior ! value, u_new(I-1) and past boundary value but with barotropic @@ -1715,7 +1724,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + if (OBC%time_filter) then + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + endif elseif (segment%oblique) 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 backward sasha for I-1 @@ -1730,9 +1741,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = US%L_T_to_m_s**2*dhdt*dhdx cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + if (OBC%time_filter) then + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif segment%rx_normal(I,j,k) = rx_avg segment%ry_normal(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg @@ -1740,11 +1757,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & (cff_avg + rx_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) - OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + if (OBC%time_filter) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary + ! implementation as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + endif elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I-1,j,k) endif @@ -1764,16 +1783,25 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - enddo + if (OBC%time_filter) then + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new + dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 + rx_tangential(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + enddo + endif enddo if (segment%radiation_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (v_new(I,J,k) + rx_avg*v_new(I-1,J,k)) / (1.0+rx_avg) + segment%tangential_vel(I,J,k) = (v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) / (1.0+rx_avg) enddo ; enddo endif if (segment%nudged_tan) then @@ -1828,20 +1856,41 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) - ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) - cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) - cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) - enddo + if (OBC%time_filter) then + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) + ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new + dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(j,1,k) + elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(j+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + rx_new = US%L_T_to_m_s**2*dhdt*dhdx + cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_tangential(I,j,k) = rx_new + ry_tangential(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif enddo if (segment%oblique_tan) then - do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB rx_avg = rx_tangential(I,J,k) ry_avg = ry_tangential(I,J,k) cff_avg = cff_tangential(I,J,k) @@ -1907,15 +1956,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sasha for I+1 rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + if (OBC%time_filter) then + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + else + rx_avg = rx_new + endif segment%rx_normal(I,j,k) = rx_avg ! The new boundary value is interpolated between future interior ! value, u_new(I+1) and past boundary value but with barotropic ! accelerations, u_new(I). segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + if (OBC%time_filter) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + endif elseif (segment%oblique) 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 @@ -1931,9 +1986,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = US%L_T_to_m_s**2*dhdt*dhdx cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new + if (OBC%time_filter) then + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif segment%rx_normal(I,j,k) = rx_avg segment%ry_normal(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg @@ -1943,9 +2004,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (cff_avg + rx_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) - OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + if (OBC%time_filter) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + endif elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I+1,j,k) endif @@ -1965,11 +2030,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - enddo + if (OBC%time_filter) then + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 + rx_tangential(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + enddo + endif enddo if (segment%radiation_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB @@ -2029,20 +2103,41 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) - ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) - cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) - cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) - do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) - enddo + if (OBC%time_filter) then + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) + ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + else + do J=segment%HI%JsdB,segment%HI%JedB + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(j,1,k) + elseif (dhdt*(segment%grad_tan(j,1,k) + segment%grad_tan(j+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(j+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + rx_new = US%L_T_to_m_s**2*dhdt*dhdx + cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_tangential(I,j,k) = rx_new + ry_tangential(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif enddo if (segment%oblique_tan) then - do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB rx_avg = rx_tangential(I,J,k) ry_avg = ry_tangential(I,J,k) cff_avg = cff_tangential(I,J,k) @@ -2108,15 +2203,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = (v_new(i,J-1,k) - v_new(i,J-2,k)) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + if (OBC%time_filter) then + ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + else + ry_avg = ry_new + endif segment%ry_normal(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J-1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + if (OBC%time_filter) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + endif elseif (segment%oblique) 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 @@ -2132,9 +2233,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + if (OBC%time_filter) then + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif segment%rx_normal(I,j,k) = rx_avg segment%ry_normal(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg @@ -2142,11 +2249,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) - OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + if (OBC%time_filter) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + endif elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J-1,k) endif @@ -2166,11 +2275,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) J=segment%HI%JsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) - enddo + if (OBC%time_filter) then + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new + dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I-1 + rx_tangential(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + enddo + endif enddo if (segment%radiation_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB @@ -2231,20 +2349,41 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) - cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) - cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) - enddo + if (OBC%time_filter) then + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j,k)-u_new(I,j,k) !old-new + dhdx = u_new(I,j,k)-u_new(I,j-1,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(i,1,k) + elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(i+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + rx_new = US%L_T_to_m_s**2*dhdt*dhdx + cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_tangential(I,j,k) = rx_new + ry_tangential(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif enddo if (segment%oblique_tan) then - do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB rx_avg = rx_tangential(I,J,k) ry_avg = ry_tangential(I,J,k) cff_avg = cff_tangential(I,J,k) @@ -2310,15 +2449,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + if (OBC%time_filter) then + ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + else + ry_avg = ry_new + endif segment%ry_normal(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J+1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + if (OBC%time_filter) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + endif elseif (segment%oblique) 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 @@ -2333,9 +2478,15 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + if (OBC%time_filter) then + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + else + rx_avg = rx_new + ry_avg = ry_new + cff_avg = cff_new + endif segment%rx_normal(I,j,k) = rx_avg segment%ry_normal(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg @@ -2343,11 +2494,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) - OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + if (OBC%time_filter) then + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + endif elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J+1,k) endif @@ -2431,20 +2584,41 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) - cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) - cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) - cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) - enddo + if (OBC%time_filter) then + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdx = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 + if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then + dhdy = segment%grad_tan(i,1,k) + elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_tan(i+1,1,k) + endif + if (dhdt*dhdx < 0.0) dhdt = 0.0 + rx_new = US%L_T_to_m_s**2*dhdt*dhdx + cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_tangential(I,j,k) = rx_new + ry_tangential(i,J,k) = ry_new + cff_tangential(i,J,k) = cff_new + enddo + endif enddo if (segment%oblique_tan) then - do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB rx_avg = rx_tangential(I,J,k) ry_avg = ry_tangential(I,J,k) cff_avg = cff_tangential(I,J,k) @@ -2599,7 +2773,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo if (segment%oblique_tan) then do k=1,G%ke - do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + do J=max(segment%HI%jsd-1, G%HI%jsd),min(segment%HI%jed+1, G%HI%jed) segment%grad_tan(j,1,k) = (vvel(i-1,J,k)-vvel(i-1,J-1,k)) * G%mask2dT(i-1,j) segment%grad_tan(j,2,k) = (vvel(i,J,k)-vvel(i,J-1,k)) * G%mask2dT(i,j) enddo @@ -2625,7 +2799,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo if (segment%oblique_tan) then do k=1,G%ke - do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + do J=max(segment%HI%jsd-1, G%HI%jsd),min(segment%HI%jed+1, G%HI%jed) segment%grad_tan(j,1,k) = (vvel(i+2,J,k)-vvel(i+2,J-1,k)) * G%mask2dT(i+2,j) segment%grad_tan(j,2,k) = (vvel(i+1,J,k)-vvel(i+1,J-1,k)) * G%mask2dT(i+1,j) enddo @@ -2653,7 +2827,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo if (segment%oblique_tan) then do k=1,G%ke - do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + do I=max(segment%HI%isd-1, G%HI%isd),min(segment%HI%ied+1, G%HI%ied) segment%grad_tan(i,1,k) = (uvel(I,j-1,k)-uvel(I-1,j-1,k)) * G%mask2dT(i,j-1) segment%grad_tan(i,2,k) = (uvel(I,j,k)-uvel(I-1,j,k)) * G%mask2dT(i,j) enddo @@ -2680,7 +2854,7 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) enddo if (segment%oblique_tan) then do k=1,G%ke - do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + do I=max(segment%HI%isd-1, G%HI%isd),min(segment%HI%ied+1, G%HI%ied) segment%grad_tan(i,1,k) = (uvel(I,j+2,k)-uvel(I-1,j+2,k)) * G%mask2dT(i,j+2) segment%grad_tan(i,2,k) = (uvel(I,j+1,k)-uvel(I-1,j+1,k)) * G%mask2dT(i,j+1) enddo @@ -2847,7 +3021,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%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & - OBC%computed_vorticity .or. OBC%computed_strain) then + segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) then allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_vel(:,:,:)=0.0 endif if (segment%nudged_tan) then @@ -2867,7 +3041,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%cff_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif if (segment%oblique_tan) then - allocate(segment%grad_tan(jsd:jed,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 + allocate(segment%grad_tan(jsd-1:jed+1,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 endif if (segment%oblique_grad) then allocate(segment%grad_gradient(jsd:jed,2,OBC%ke)); segment%grad_gradient(:,:,:) = 0.0 @@ -2890,7 +3064,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%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & - OBC%computed_vorticity .or. OBC%computed_strain) then + segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) then allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_vel(:,:,:)=0.0 endif if (segment%nudged_tan) then @@ -2910,7 +3084,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%cff_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif if (segment%oblique_tan) then - allocate(segment%grad_tan(isd:ied,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 + allocate(segment%grad_tan(isd-1:ied+1,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 endif if (segment%oblique_grad) then allocate(segment%grad_gradient(isd:ied,2,OBC%ke)); segment%grad_gradient(:,:,:) = 0.0 From c9f9787beae1a5b88656720da48c7127c4a31802 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 5 Sep 2019 17:37:56 -0400 Subject: [PATCH 043/259] ALE and mixed layer scaling diag fixes This patch fixes the dimensional scaling of the pre-ALE u and v diagnostics, and the uhml and vhml mixed layer diagnostics. --- src/ALE/MOM_ALE.F90 | 4 ++-- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 33b498a60a..def4148f25 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -246,9 +246,9 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) ! These diagnostics of the state variables before ALE are useful for ! debugging the ALE code. CS%id_u_preale = register_diag_field('ocean_model', 'u_preale', diag%axesCuL, Time, & - 'Zonal velocity before remapping', 'm s-1') + 'Zonal velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) CS%id_v_preale = register_diag_field('ocean_model', 'v_preale', diag%axesCvL, Time, & - 'Meridional velocity before remapping', 'm s-1') + 'Meridional velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_preale = register_diag_field('ocean_model', 'h_preale', diag%axesTL, Time, & 'Layer Thickness before remapping', get_thickness_units(GV), v_extensive=.true.) CS%id_T_preale = register_diag_field('ocean_model', 'T_preale', diag%axesTL, Time, & diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index c4a2d0c38f..6543ab7af6 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -884,8 +884,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%diag => diag - if (GV%Boussinesq) then ; flux_to_kg_per_s = GV%Rho0*US%L_to_m**2*US%s_to_T - else ; flux_to_kg_per_s = US%L_to_m**2*US%s_to_T ; endif + if (GV%Boussinesq) then ; flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T + else ; flux_to_kg_per_s = GV%H_to_m * US%L_to_m**2 * US%s_to_T ; endif CS%id_uhml = register_diag_field('ocean_model', 'uhml', diag%axesCuL, Time, & 'Zonal Thickness Flux to Restratify Mixed Layer', 'kg s-1', conversion=flux_to_kg_per_s, & From fe27c05a37e6fad91a38db802c972a5bd5197843 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 5 Sep 2019 14:07:09 -0800 Subject: [PATCH 044/259] Swap in/out for tracer reservoirs. - make it consistent with documentation. --- src/core/MOM_open_boundary.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 63e7b26a61..d3c3b91f61 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4301,12 +4301,12 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) do m=1,ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then do k=1,nz - u_L_in=max((idir*uhr(I,j,k))*segment%Tr_InvLscale_in/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) - u_L_out=min((idir*uhr(I,j,k))*segment%Tr_InvLscale_out/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) - fac1=1.0+dt*(u_L_in-u_L_out) + u_L_out=max((idir*uhr(I,j,k))*segment%Tr_InvLscale_out/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) + u_L_in=min((idir*uhr(I,j,k))*segment%Tr_InvLscale_in/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) + fac1=1.0+dt*(u_L_out-u_L_in) segment%tr_Reg%Tr(m)%tres(I,j,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & - dt*(u_L_in*Reg%Tr(m)%t(I+ishift,j,k) - & - u_L_out*segment%tr_Reg%Tr(m)%t(I,j,k))) + dt*(u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & + u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) enddo endif enddo @@ -4325,12 +4325,12 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) do m=1,ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then do k=1,nz - v_L_in=max((jdir*vhr(i,J,k))*segment%Tr_InvLscale_in/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) - v_L_out=min((jdir*vhr(i,J,k))*segment%Tr_InvLscale_out/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) - fac1=1.0+dt*(v_L_in-v_L_out) + v_L_out=max((jdir*vhr(i,J,k))*segment%Tr_InvLscale_out/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) + v_L_in=min((jdir*vhr(i,J,k))*segment%Tr_InvLscale_in/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) + fac1=1.0+dt*(v_L_out-v_L_in) segment%tr_Reg%Tr(m)%tres(i,J,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & - dt*(v_L_in*Reg%Tr(m)%t(i,J+jshift,k) - & - v_L_out*segment%tr_Reg%Tr(m)%t(i,J,k))) + dt*(v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & + v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) enddo endif enddo From d4f7f0e58f118ce0f0e75685f1491793d3a6658e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sat, 7 Sep 2019 09:39:23 -0800 Subject: [PATCH 045/259] Got rid of OBC_TIME_FILTER option. --- src/core/MOM_open_boundary.F90 | 52 ++++++++++++++++------------------ 1 file changed, 24 insertions(+), 28 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d3c3b91f61..a2897c97b8 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -216,7 +216,6 @@ module MOM_open_boundary !! for input from user directory. logical :: update_OBC = .false. !< Is OBC data time-dependent logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs - logical :: time_filter !< If true, apply time filtering to phase speed. logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the relative vorticity on open boundaries. @@ -382,9 +381,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& "viscosity term.", default=.false.) - call get_param(param_file, mdl, "OBC_TIME_FILTER", OBC%time_filter, & - "If true, apply a time filter to the calculation of the phase speed at the"//& - "boundary.", default=.true.) call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & "If true, set the areas outside open boundaries to be land.", & default=.false.) @@ -1656,7 +1652,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) !! Copy previously calculated phase velocity from global arrays into segments !! This is terribly inefficient and temporary solution for continuity across restarts !! and needs to be revisited in the future. - if (OBC%time_filter) then + if (OBC%gamma_uv > 0.0) then do n=1,OBC%number_of_segments segment=>OBC%segment(n) if (.not. segment%on_pe) cycle @@ -1712,7 +1708,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = (u_new(I-1,j,k) - u_new(I-2,j,k)) !in new time backward sasha for I-1 rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new else rx_avg = rx_new @@ -1724,7 +1720,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - if (OBC%time_filter) then + if (gamma_u > 0.0) then OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) endif elseif (segment%oblique) then @@ -1741,7 +1737,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = US%L_T_to_m_s**2*dhdt*dhdx cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new @@ -1757,7 +1753,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & (cff_avg + rx_avg) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary ! implementation as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -1783,7 +1779,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 @@ -1856,7 +1852,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) @@ -1956,7 +1952,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sasha for I+1 rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new else rx_avg = rx_new @@ -1966,7 +1962,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! value, u_new(I+1) and past boundary value but with barotropic ! accelerations, u_new(I). segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -1986,7 +1982,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = US%L_T_to_m_s**2*dhdt*dhdx cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new @@ -2004,7 +2000,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (cff_avg + rx_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - if (OBC%time_filter) then + if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -2030,7 +2026,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 @@ -2103,7 +2099,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) @@ -2203,7 +2199,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = (v_new(i,J-1,k) - v_new(i,J-2,k)) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new else ry_avg = ry_new @@ -2213,7 +2209,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! value, v_new(J-1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) @@ -2233,7 +2229,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new @@ -2249,7 +2245,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -2275,7 +2271,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) J=segment%HI%JsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 @@ -2349,7 +2345,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) @@ -2449,7 +2445,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new else ry_avg = ry_new @@ -2459,7 +2455,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! value, v_new(J+1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) @@ -2478,7 +2474,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new @@ -2494,7 +2490,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) - if (OBC%time_filter) then + if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -2584,7 +2580,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (OBC%time_filter) then + if (gamma_u > 0.0) then rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) From 9c7053bffdf09eb48ff959dae27736d6bd54f3e3 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 9 Sep 2019 09:56:40 -0400 Subject: [PATCH 046/259] Low CodeCov coverage threshold Testing a lower coverage threshold for CodeCov testing, since the current settings are distracting from this early stage of testing. --- .codecov.yml | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 .codecov.yml diff --git a/.codecov.yml b/.codecov.yml new file mode 100644 index 0000000000..4cb8decfb6 --- /dev/null +++ b/.codecov.yml @@ -0,0 +1,8 @@ +coverage: + status: + project: + default: + target: 30% + patch: + default: + target: 50% From 217eb9fe2e6bd4d4e98a8cf0a7f31936af632748 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 9 Sep 2019 13:08:32 -0400 Subject: [PATCH 047/259] Travis: Explicit 0% threshold for CodeCov The absolute code coverage target was replaced with a 100% threshold, tagging any level of coverage as a success. This will be modified later, when the coverage tests are more thorough and extendible by users. --- .codecov.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.codecov.yml b/.codecov.yml index 4cb8decfb6..576633bf6a 100644 --- a/.codecov.yml +++ b/.codecov.yml @@ -2,7 +2,7 @@ coverage: status: project: default: - target: 30% + threshold: 100% patch: default: - target: 50% + threshold: 100% From ddefcc71993e1b3cadad58612363bf26fdbea081 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 10 Sep 2019 11:31:15 -0400 Subject: [PATCH 048/259] (+) MKS thickness scaling of horizontal avg diag The horizontal_average_diag_field function uses thickness when computing layer averages in some cases. Reproducibility requires that reproducible sums be calculated in MKS units. While the grids have been converted to MKS lengths, the thickeness have not. This patch rescales the thicknesses to volumes, which restores the reproducibility of the dimentionally scaled quantities involving H. --- src/framework/MOM_diag_mediator.F90 | 5 +++-- src/framework/MOM_diag_remap.F90 | 25 +++++++++++++++---------- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 54f1934abd..674046a750 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1765,7 +1765,7 @@ subroutine post_xy_average(diag_cs, diag, field) staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point if (diag%axes%is_native) then - call horizontally_average_diag_field(diag_cs%G, diag_cs%h, & + call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, diag_cs%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & diag_cs%missing_value, field, & @@ -1783,7 +1783,8 @@ subroutine post_xy_average(diag_cs, diag, field) call assert(IMPLIES(.not. diag%axes%is_layer, nz == remap_nz+1), & 'post_xy_average: interface field dimension mismatch.') - call horizontally_average_diag_field(diag_cs%G, diag_cs%diag_remap_cs(coord)%h, & + call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, & + diag_cs%diag_remap_cs(coord)%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & diag_cs%missing_value, field, & diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 8f1d309b06..372d6d65cc 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -637,11 +637,12 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta end subroutine vertically_interpolate_diag_field !> Horizontally average field -subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, & +subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_in_y, & is_layer, is_extensive, & missing_value, field, averaged_field, & averaged_mask) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure real, dimension(:,:,:), intent(in) :: h !< The current thicknesses logical, intent(in) :: staggered_in_x !< True if the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True if the y-axis location is at v or q points @@ -663,6 +664,7 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, ! TODO: These averages could potentially be modified to use the function in ! the MOM_spatial_means module. + ! NOTE: Reproducible sums must be computed in the original MKS units if (staggered_in_x .and. .not. staggered_in_y) then if (is_layer) then @@ -673,14 +675,15 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, if (is_extensive) then do j=G%jsc, G%jec ; do I=G%isc, G%iec I1 = I - G%isdB + 1 - volume(I,j,k) = G%US%L_to_m**2*G%areaCu(I,j) * G%mask2dCu(I,j) + volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) enddo ; enddo else ! Intensive do j=G%jsc, G%jec ; do I=G%isc, G%iec I1 = i - G%isdB + 1 height = 0.5 * (h(i,j,k) + h(i+1,j,k)) - volume(I,j,k) = G%US%L_to_m**2*G%areaCu(I,j) * height * G%mask2dCu(I,j) + volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) & + * (GV%H_to_m * height) * G%mask2dCu(I,j) stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) enddo ; enddo endif @@ -689,7 +692,7 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, do k=1,nz do j=G%jsc, G%jec ; do I=G%isc, G%iec I1 = I - G%isdB + 1 - volume(I,j,k) = G%US%L_to_m**2*G%areaCu(I,j) * G%mask2dCu(I,j) + volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) enddo ; enddo enddo @@ -701,14 +704,15 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, if (is_extensive) then do J=G%jsc, G%jec ; do i=G%isc, G%iec J1 = J - G%jsdB + 1 - volume(i,J,k) = G%US%L_to_m**2*G%areaCv(i,J) * G%mask2dCv(i,J) + volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) enddo ; enddo else ! Intensive do J=G%jsc, G%jec ; do i=G%isc, G%iec J1 = J - G%jsdB + 1 height = 0.5 * (h(i,j,k) + h(i,j+1,k)) - volume(i,J,k) = G%US%L_to_m**2*G%areaCv(i,J) * height * G%mask2dCv(i,J) + volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) & + * (GV%H_to_m * height) * G%mask2dCv(i,J) stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) enddo ; enddo endif @@ -717,7 +721,7 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, do k=1,nz do J=G%jsc, G%jec ; do i=G%isc, G%iec J1 = J - G%jsdB + 1 - volume(i,J,k) = G%US%L_to_m**2*G%areaCv(i,J) * G%mask2dCv(i,J) + volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) enddo ; enddo enddo @@ -729,7 +733,7 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, if (is_extensive) then do j=G%jsc, G%jec ; do i=G%isc, G%iec if (h(i,j,k) > 0.) then - volume(i,j,k) = G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) + volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) * G%mask2dT(i,j) stuff(i,j,k) = volume(i,j,k) * field(i,j,k) else volume(i,j,k) = 0. @@ -738,7 +742,8 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, enddo ; enddo else ! Intensive do j=G%jsc, G%jec ; do i=G%isc, G%iec - volume(i,j,k) = G%US%L_to_m**2*G%areaT(i,j) * h(i,j,k) * G%mask2dT(i,j) + volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) & + * (GV%H_to_m * h(i,j,k)) * G%mask2dT(i,j) stuff(i,j,k) = volume(i,j,k) * field(i,j,k) enddo ; enddo endif @@ -746,7 +751,7 @@ subroutine horizontally_average_diag_field(G, h, staggered_in_x, staggered_in_y, else ! Interface do k=1,nz do j=G%jsc, G%jec ; do i=G%isc, G%iec - volume(i,j,k) = G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) + volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) * G%mask2dT(i,j) stuff(i,j,k) = volume(i,j,k) * field(i,j,k) enddo ; enddo enddo From c777b4cd2453c41f28ea5e58ee3e84d9723b5346 Mon Sep 17 00:00:00 2001 From: MFJansen Date: Tue, 10 Sep 2019 10:39:18 -0500 Subject: [PATCH 049/259] Bug fix in computation of topographic beta I also changed the sign in the definition of beta_topo to be consistent with sign of PV gradient. The bug fix will change answers in configurations that use the topographc Rhines scale (although in practice, difference will be very small when using Mercator Grid). --- src/parameterizations/lateral/MOM_MEKE.F90 | 50 +++++++++++----------- 1 file changed, 24 insertions(+), 26 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 6c038a4eb5..dc44601f71 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -661,20 +661,19 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m else !### Consider different combinations of these estimates of topographic beta, and the use ! of the water column thickness instead of the bathymetric depth. - beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & - (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & - / max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & - + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & - / max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) - !### There is a bug in the 4th lne below, where IdxCu should be IdyCv. - beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & - (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & - / max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & - (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & - / max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) + beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & + / max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & + + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & + / max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) + beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & + / max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & + (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdyCv(i,J-1) & + / max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) endif - beta = sqrt((G%dF_dx(i,j) - beta_topo_x)**2 + & - (G%dF_dy(i,j) - beta_topo_y)**2 ) + beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & + (G%dF_dy(i,j) + beta_topo_y)**2 ) I_H = US%L_to_m*GV%Rho0 * I_mass(i,j) @@ -808,20 +807,19 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, & else !### Consider different combinations of these estimates of topographic beta, and the use ! of the water column thickness instead of the bathymetric depth. - beta_topo_x = CS%MEKE_topographic_beta * FatH * 0.5 * ( & - (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & - / max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & - + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & - / max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) - !### There is a bug in the 4th lne below, where IdxCu should be IdyCv. - beta_topo_y = CS%MEKE_topographic_beta * FatH * 0.5 * ( & - (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & - / max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & - (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdxCu(i,J-1) & - / max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) + beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i+1,j)-G%bathyT(i,j)) * G%IdxCu(I,j) & + / max(G%bathyT(i+1,j),G%bathyT(i,j), GV%H_subroundoff) & + + (G%bathyT(i,j)-G%bathyT(i-1,j)) * G%IdxCu(I-1,j) & + / max(G%bathyT(i,j),G%bathyT(i-1,j), GV%H_subroundoff) ) + beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & + (G%bathyT(i,j+1)-G%bathyT(i,j)) * G%IdyCv(i,J) & + / max(G%bathyT(i,j+1),G%bathyT(i,j), GV%H_subroundoff) + & + (G%bathyT(i,j)-G%bathyT(i,j-1)) * G%IdyCv(i,J-1) & + / max(G%bathyT(i,j),G%bathyT(i,j-1), GV%H_subroundoff) ) endif - beta = sqrt((G%dF_dx(i,j) - beta_topo_x)**2 + & - (G%dF_dy(i,j) - beta_topo_y)**2 ) + beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & + (G%dF_dy(i,j) + beta_topo_y)**2 ) else beta = 0. From 7e78e87189e0ba7d3a099fa65085aae497dab104 Mon Sep 17 00:00:00 2001 From: MFJansen Date: Tue, 10 Sep 2019 10:43:55 -0500 Subject: [PATCH 050/259] Bug fix in evaluation of MEKE%mom_src This bug would have only affected simulations that use the Ro scaling for backscatter, and the issue only occured after the introduction of GM+E. To my knowledge no simulations have been performed that were be affected by this. --- .../lateral/MOM_hor_visc.F90 | 96 +++++++++---------- 1 file changed, 48 insertions(+), 48 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 4c545953d0..e53575539e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1365,59 +1365,59 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif endif - if (MEKE%backscatter_Ro_c /= 0.) then - do j=js,je ; do i=is,ie - FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) ) - Shear_mag = sqrt(sh_xx(i,j)*sh_xx(i,j) + & - 0.25*((sh_xy(I-1,J-1)*sh_xy(I-1,J-1) + sh_xy(I,J)*sh_xy(I,J)) + & - (sh_xy(I-1,J)*sh_xy(I-1,J) + sh_xy(I,J-1)*sh_xy(I,J-1)))) - if (CS%answers_2018) then - FatH = (US%s_to_T*FatH)**MEKE%backscatter_Ro_pow ! f^n - ! Note the hard-coded dimensional constant in the following line that can not - ! be rescaled for dimensional consistency. - Shear_mag = ( ( (US%s_to_T*Shear_mag)**MEKE%backscatter_Ro_pow ) + 1.e-30 ) & - * MEKE%backscatter_Ro_c ! c * D^n - ! The Rossby number function is g(Ro) = 1/(1+c.Ro^n) - ! RoScl = 1 - g(Ro) - RoScl = Shear_mag / ( FatH + Shear_mag ) ! = 1 - f^n/(f^n+c*D^n) - else - if (FatH <= backscat_subround*Shear_mag) then - RoScl = 1.0 - else - Sh_F_pow = MEKE%backscatter_Ro_c * (Shear_mag / FatH)**MEKE%backscatter_Ro_pow - RoScl = Sh_F_pow / (1.0 + Sh_F_pow) ! = 1 - f^n/(f^n+c*D^n) - endif - endif - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_kg_m2 * ( & - ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - +0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J))*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +(str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1))*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J))*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +(str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1))*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) - enddo ; enddo - endif ! MEKE%backscatter - if (CS%use_GME) then do j=js,je ; do i=is,ie ! MEKE%mom_src now is sign definite because it only uses the dissipation MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + MAX(FrictWork_diss(i,j,k), FrictWorkMax(i,j,k)) enddo ; enddo - else - do j=js,je ; do i=is,ie - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) - enddo ; enddo - endif ! CS%use_GME - + else ! use_GME + if (MEKE%backscatter_Ro_c /= 0.) then + do j=js,je ; do i=is,ie + FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) ) + Shear_mag = sqrt(sh_xx(i,j)*sh_xx(i,j) + & + 0.25*((sh_xy(I-1,J-1)*sh_xy(I-1,J-1) + sh_xy(I,J)*sh_xy(I,J)) + & + (sh_xy(I-1,J)*sh_xy(I-1,J) + sh_xy(I,J-1)*sh_xy(I,J-1)))) + if (CS%answers_2018) then + FatH = (US%s_to_T*FatH)**MEKE%backscatter_Ro_pow ! f^n + ! Note the hard-coded dimensional constant in the following line that can not + ! be rescaled for dimensional consistency. + Shear_mag = ( ( (US%s_to_T*Shear_mag)**MEKE%backscatter_Ro_pow ) + 1.e-30 ) & + * MEKE%backscatter_Ro_c ! c * D^n + ! The Rossby number function is g(Ro) = 1/(1+c.Ro^n) + ! RoScl = 1 - g(Ro) + RoScl = Shear_mag / ( FatH + Shear_mag ) ! = 1 - f^n/(f^n+c*D^n) + else + if (FatH <= backscat_subround*Shear_mag) then + RoScl = 1.0 + else + Sh_F_pow = MEKE%backscatter_Ro_c * (Shear_mag / FatH)**MEKE%backscatter_Ro_pow + RoScl = Sh_F_pow / (1.0 + Sh_F_pow) ! = 1 - f^n/(f^n+c*D^n) + endif + endif + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_kg_m2 * ( & + ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + +0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J))*( & + (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & + +(str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1))*( & + (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & + +((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J))*( & + (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & + +(str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1))*( & + (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + enddo ; enddo + else ! MEKE%backscatter_Ro_c + do j=js,je ; do i=is,ie + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) + enddo ; enddo + endif ! MEKE%backscatter_Ro_c + endif !use GME + if (CS%use_GME .and. associated(MEKE)) then if (associated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie From 66dab94d6cf3f762eed49f9e2eedfc42647e9cf6 Mon Sep 17 00:00:00 2001 From: MFJansen Date: Tue, 10 Sep 2019 13:39:05 -0500 Subject: [PATCH 051/259] removed trailing spaces --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index e53575539e..82d20c239b 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1416,8 +1416,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) enddo ; enddo endif ! MEKE%backscatter_Ro_c - endif !use GME - + endif !use GME + if (CS%use_GME .and. associated(MEKE)) then if (associated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie From af62e2e678df28357a7cc9726347c9b3ddcf9de5 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 10 Sep 2019 15:31:20 -0400 Subject: [PATCH 052/259] Diagnostic dimensional scaling fixes This fixes up the dimensional scaling of several diagnostics: * dynamics_h_tendency * MLD_Restrat * ea, eb * h_predia * frazil_h We also include a change to the flux_to_kg_per_s scaling factor. Previously, this was dynamically set the flux units to either m3 s-1 or kg s-1 depending on the Boussinesq mode. However, the units of the diagnostics using this factor (uhml, vhml) were always explicitly set to kg -1. Assuming that the scaled fluxes were H L2 T-1, this would have given the wrong scaling in non-Boussinesq mode. We resolve this by removing the conditional and always using GV%H_to_kg_m2 when defining this scaling factor. --- src/diagnostics/MOM_diagnostics.F90 | 2 +- .../lateral/MOM_mixed_layer_restrat.F90 | 20 ++++++++--------- .../vertical/MOM_diabatic_driver.F90 | 22 ++++++++++++++----- 3 files changed, 27 insertions(+), 17 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 4aa6fad710..8fa106c4e0 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1845,7 +1845,7 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) 'm s-1', v_extensive=.true., conversion=GV%H_to_m) IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & - 'm s-1', v_extensive=.true.) + 'm s-1', v_extensive=.true., conversion=GV%H_to_m) end subroutine register_transport_diags diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 6543ab7af6..ba241ea4b1 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -884,30 +884,30 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%diag => diag - if (GV%Boussinesq) then ; flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T - else ; flux_to_kg_per_s = GV%H_to_m * US%L_to_m**2 * US%s_to_T ; endif + flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T CS%id_uhml = register_diag_field('ocean_model', 'uhml', diag%axesCuL, Time, & - 'Zonal Thickness Flux to Restratify Mixed Layer', 'kg s-1', conversion=flux_to_kg_per_s, & - y_cell_method='sum', v_extensive=.true.) + 'Zonal Thickness Flux to Restratify Mixed Layer', 'kg s-1', & + conversion=flux_to_kg_per_s, y_cell_method='sum', v_extensive=.true.) CS%id_vhml = register_diag_field('ocean_model', 'vhml', diag%axesCvL, Time, & - 'Meridional Thickness Flux to Restratify Mixed Layer', 'kg s-1', conversion=flux_to_kg_per_s, & - x_cell_method='sum', v_extensive=.true.) + 'Meridional Thickness Flux to Restratify Mixed Layer', 'kg s-1', & + conversion=flux_to_kg_per_s, x_cell_method='sum', v_extensive=.true.) CS%id_urestrat_time = register_diag_field('ocean_model', 'MLu_restrat_time', diag%axesCu1, Time, & 'Mixed Layer Zonal Restratification Timescale', 's', conversion=US%T_to_s) CS%id_vrestrat_time = register_diag_field('ocean_model', 'MLv_restrat_time', diag%axesCv1, Time, & 'Mixed Layer Meridional Restratification Timescale', 's', conversion=US%T_to_s) CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & - 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', 'm') + 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', 'm', & + conversion=GV%H_to_m) CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & - 'm s2', conversion=US%m_to_Z*US%L_to_m**2*US%s_to_T**2) + 'm s2', conversion=US%m_to_Z*(US%L_to_m**2)*(US%s_to_T**2)) CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & 'Transport stream function amplitude for zonal restratification of mixed layer', & - 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) CS%id_vDml = register_diag_field('ocean_model', 'vdml_restrat', diag%axesCv1, Time, & 'Transport stream function amplitude for meridional restratification of mixed layer', & - 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) CS%id_uml = register_diag_field('ocean_model', 'uml_restrat', diag%axesCu1, Time, & 'Surface zonal velocity component of mixed layer restratification', & 'm s-1', conversion=US%L_T_to_m_s) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index e6f644d210..2354fcf933 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3203,6 +3203,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di real :: Kd integer :: num_mode logical :: use_temperature, differentialDiffusion + real :: H_to_MKS !< Conversion factor from H to equivalent MKS unit ! This "include" declares and sets the variable "version". #include "version_variable.h" @@ -3361,8 +3362,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Register all available diagnostics for this module. - if (GV%Boussinesq) then ; thickness_units = "m" - else ; thickness_units = "kg m-2" ; endif + if (GV%Boussinesq) then + thickness_units = "m" + H_to_MKS = GV%H_to_m + else + thickness_units = "kg m-2" + H_to_MKS = GV%H_to_kg_m2 + endif CS%id_ea_t = register_diag_field('ocean_model','ea_t',diag%axesTL,Time, & 'Layer (heat) entrainment from above per timestep','m') @@ -3374,9 +3380,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Layer (salt) entrainment from below per timestep', 'm') ! used by layer diabatic CS%id_ea = register_diag_field('ocean_model','ea',diag%axesTL,Time, & - 'Layer entrainment from above per timestep','m') + 'Layer entrainment from above per timestep','m', & + conversion=GV%H_to_m) CS%id_eb = register_diag_field('ocean_model','eb',diag%axesTL,Time, & - 'Layer entrainment from below per timestep', 'm') + 'Layer entrainment from below per timestep', 'm', & + conversion=GV%H_to_m) CS%id_wd = register_diag_field('ocean_model','wd',diag%axesTi,Time, & 'Diapycnal velocity', 'm s-1') if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) @@ -3446,7 +3454,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_v_predia = register_diag_field('ocean_model', 'v_predia', diag%axesCvL, Time, & 'Meridional velocity before diabatic forcing', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_predia = register_diag_field('ocean_model', 'h_predia', diag%axesTL, Time, & - 'Layer Thickness before diabatic forcing', thickness_units, v_extensive=.true.) + 'Layer Thickness before diabatic forcing', thickness_units, v_extensive=.true., & + conversion=H_to_MKS) CS%id_e_predia = register_diag_field('ocean_model', 'e_predia', diag%axesTi, Time, & 'Interface Heights before diabatic forcing', 'm') if (use_temperature) then @@ -3640,7 +3649,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! diagnostics for tendencies of temp and heat due to frazil CS%id_frazil_h = register_diag_field('ocean_model', 'frazil_h', diag%axesTL, Time, & - long_name = 'Cell Thickness', standard_name='cell_thickness', units='m', v_extensive=.true.) + long_name = 'Cell Thickness', standard_name='cell_thickness', units='m', & + v_extensive=.true., conversion=GV%H_to_m) ! diagnostic for tendency of temp due to frazil CS%id_frazil_temp_tend = register_diag_field('ocean_model',& From 1016be3cba6b07a88764c4aad95ef2253ef4d476 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 11 Sep 2019 15:04:21 -0400 Subject: [PATCH 053/259] +Pass timestep arguments to vertvisc in [T] Rescaled the timestep arguments to set_viscous_ML, vertvisc, vertvisc_coef, vertvisc_remnant, write_u_accel and write_v_accel to use units of [T]. All answers are bitwise identical, but the units of some public arguments have been rescaled. --- src/core/MOM_dynamics_split_RK2.F90 | 20 +++---- src/core/MOM_dynamics_unsplit.F90 | 17 +++--- src/core/MOM_dynamics_unsplit_RK2.F90 | 17 +++--- src/diagnostics/MOM_PointAccel.F90 | 12 ++-- .../vertical/MOM_set_viscosity.F90 | 10 ++-- .../vertical/MOM_vert_friction.F90 | 58 +++++++++---------- 6 files changed, 66 insertions(+), 68 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 1f43a699a1..839dcc9f24 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -56,7 +56,7 @@ module MOM_dynamics_split_RK2 use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant -use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init, vertvisc_CS +use MOM_vert_friction, only : vertvisc_init, vertvisc_CS use MOM_vert_friction, only : updateCFLtruncationValue use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units @@ -480,15 +480,15 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & enddo call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, & + call set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) if (CS%debug) then call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym) endif - call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call vertvisc_coef(up, vp, h, forces, visc, dt_in_T, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_in_T, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") @@ -580,9 +580,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) then call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif - call vertvisc_coef(up, vp, h, forces, visc, US%T_to_s*dt_pred, G, GV, US, CS%vertvisc_CSp, & + call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, & CS%OBC) - call vertvisc(up, vp, h, forces, visc, US%T_to_s*dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") if (G%nonblocking_updates) then @@ -590,7 +590,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, US%T_to_s*dt_pred, G, GV, US, CS%vertvisc_CSp) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -779,15 +779,15 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + call vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u, v, h, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_in_T, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 9e8be65d7a..58d04cff5a 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -94,8 +94,7 @@ module MOM_dynamics_unsplit use MOM_thickness_diffuse, only : thickness_diffuse_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type -use MOM_vert_friction, only : vertvisc, vertvisc_coef -use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init, vertvisc_CS +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units use MOM_wave_interface, only: wave_parameters_CS @@ -344,13 +343,13 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! up <- up + dt/2 d/dz visc d/dz up call cpu_clock_begin(id_clock_vertvisc) call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h_av, tv, forces, visc, dt*0.5, G, GV, US, & + call set_viscous_ML(u, v, h_av, tv, forces, visc, dt_in_T*0.5, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) !### I think that the time steps in the next two calls should be dt_pred. - call vertvisc_coef(up, vp, h_av, forces, visc, dt*0.5, G, GV, US, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt_in_T*0.5, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h_av, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc(up, vp, h_av, forces, visc, dt_in_T*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -412,9 +411,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, & + call vertvisc_coef(upp, vpp, hp, forces, visc, dt_in_T*0.5, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc(upp, vpp, hp, forces, visc, dt_in_T*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(upp, vpp, G%Domain, clock=id_clock_pass) @@ -483,8 +482,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u <- u + dt d/dz visc d/dz u call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc_coef(u, v, h_av, forces, visc, dt_in_T, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u, v, h_av, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(u, v, G%Domain, clock=id_clock_pass) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index af33db8011..97ef3ede73 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -92,8 +92,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_thickness_diffuse, only : thickness_diffuse_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type -use MOM_vert_friction, only : vertvisc, vertvisc_coef -use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init, vertvisc_CS +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units @@ -342,12 +341,12 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(up, vp, h_av, tv, forces, visc, US%T_to_s*dt_pred, G, GV, US, & + call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_pred, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, US%T_to_s*dt_pred, G, GV, US, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h_av, forces, visc, US%T_to_s*dt_pred, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -397,13 +396,13 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt_in_T, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc(up, vp, h_av, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, & + call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt_in_T, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& + call vertvisc(u_in, v_in, h_av, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp,& G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index e0bbd832bb..dd72378671 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -66,7 +66,7 @@ module MOM_PointAccel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of zonal velocities over the !! previous timestep. This subroutine is called from vertvisc. -subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, str, a, hv) +subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rpt, str, a, hv) integer, intent(in) :: I !< The zonal index of the column to be documented. integer, intent(in) :: j !< The meridional index of the column to be documented. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -80,7 +80,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st !! accelerations in the momentum equations. type(cont_diag_ptrs), intent(in) :: CDp !< A structure with pointers to various terms !! in the continuity equations. - real, intent(in) :: dt !< The ocean dynamics time step [s]. + real, intent(in) :: dt_in_T !< The ocean dynamics time step [T ~> s]. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1]. @@ -95,6 +95,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real :: f_eff, CFL real :: Angstrom real :: truncvel, du + real :: dt ! The time step [s] real :: Inorm(SZK_(G)) real :: e(SZK_(G)+1) real :: h_scale, uh_scale @@ -106,6 +107,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st integer :: file Angstrom = GV%Angstrom_H + GV%H_subroundoff + dt = US%T_to_s*dt_in_T h_scale = GV%H_to_m ; uh_scale = GV%H_to_m ! if (.not.associated(CS)) return @@ -397,7 +399,7 @@ end subroutine write_u_accel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of meridional velocities over !! the previous timestep. This subroutine is called from vertvisc. -subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, str, a, hv) +subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rpt, str, a, hv) integer, intent(in) :: i !< The zonal index of the column to be documented. integer, intent(in) :: J !< The meridional index of the column to be documented. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -411,7 +413,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st !! accelerations in the momentum equations. type(cont_diag_ptrs), intent(in) :: CDp !< A structure with pointers to various terms in !! the continuity equations. - real, intent(in) :: dt !< The ocean dynamics time step [s]. + real, intent(in) :: dt_in_T !< The ocean dynamics time step [T ~> s]. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1]. @@ -426,6 +428,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real :: f_eff, CFL real :: Angstrom real :: truncvel, dv + real :: dt ! The time step [s] real :: Inorm(SZK_(G)) real :: e(SZK_(G)+1) real :: h_scale, uh_scale @@ -437,6 +440,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st integer :: file Angstrom = GV%Angstrom_H + GV%H_subroundoff + dt = US%T_to_s*dt_in_T h_scale = GV%H_to_m ; uh_scale = GV%H_to_m ! if (.not.associated(CS)) return diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 92466266b8..30648c7d61 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -273,7 +273,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) Vol_quit = 0.9*GV%Angstrom_H + h_neglect C2pi_3 = 8.0*atan(1.0)/3.0 - if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(BBL): "//& + if (.not.associated(CS)) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& "Module must be initialized before it is used.") if (.not.CS%bottomdraglaw) return @@ -1002,7 +1002,7 @@ end function set_u_at_v !! A bulk Richardson criterion or the thickness of the topmost NKML layers (with a bulk mixed layer) !! are currently used. The thicknesses are given in terms of fractional layers, so that this !! thickness will move as the thickness of the topmost layers change. -subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetrize) +subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, symmetrize) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1018,7 +1018,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt_in_T !< Time increment [T ~> s]. type(set_visc_CS), pointer :: CS !< The control structure returned by a previous !! call to vertvisc_init. logical, optional, intent(in) :: symmetrize !< If present and true, do extra calculations @@ -1125,7 +1125,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml - if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc_ML): "//& + if (.not.associated(CS)) call MOM_error(FATAL,"MOM_set_viscosity(visc_ML): "//& "Module must be initialized before it is used.") if (.not.(CS%dynamic_viscous_ML .or. associated(forces%frac_shelf_u) .or. & associated(forces%frac_shelf_v)) ) return @@ -1141,7 +1141,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri OBC => CS%OBC use_EOS = associated(tv%eqn_of_state) - dt_Rho0 = dt/GV%H_to_kg_m2 + dt_Rho0 = US%T_to_s*dt_in_T / GV%H_to_kg_m2 h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / GV%Rho0 diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index b282995d3f..fe14380617 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -142,7 +142,7 @@ module MOM_vert_friction !! There is an additional stress term on the right-hand side !! if DIRECT_STRESS is true, applied to the surface layer. -subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & +subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS, & taux_bot, tauy_bot, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -155,7 +155,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure type(accel_diag_ptrs), intent(inout) :: ADp !< Accelerations in the momentum !! equations for diagnostics @@ -185,7 +185,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: Hmix ! The mixed layer thickness over which stress ! is applied with direct_stress [H ~> m or kg m-2]. real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. - real :: dt_in_T ! The timestep [T ~> s] real :: Idt ! The inverse of the time step [T-1 ~> s-1]. real :: dt_Rho0 ! The time step divided by the mean density [L s2 H m T-1 kg-1 ~> s m3 kg-1 or s]. real :: Rho0 ! A density used to convert drag laws into stress in Pa [kg m-3]. @@ -214,7 +213,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & Hmix = CS%Hmix_stress I_Hmix = 1.0 / Hmix endif - dt_in_T = US%s_to_T*dt dt_Rho0 = US%m_s_to_L_T*US%T_to_s * dt_in_T / GV%H_to_kg_m2 dt_Z_to_H = dt_in_T*GV%Z_to_H Rho0 = GV%Rho0 @@ -422,7 +420,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ! end of v-component J loop - call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) + call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, US, CS) ! Here the velocities associated with open boundary conditions are applied. if (associated(OBC)) then @@ -459,7 +457,7 @@ end subroutine vertvisc !! after a time-step of viscosity, and the fraction of a time-step's !! worth of barotropic acceleration that a layer experiences after !! viscosity is applied. -subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) +subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt_in_T, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag @@ -471,7 +469,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) intent(inout) :: visc_rem_v !< Fraction of a time-step's worth of a !! barotopic acceleration that a layer experiences after !! viscosity is applied in the meridional direction [nondim] - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure @@ -493,7 +491,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") - dt_Z_to_H = US%s_to_T*dt*GV%Z_to_H + dt_Z_to_H = dt_in_T*GV%Z_to_H do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo @@ -567,7 +565,7 @@ end subroutine vertvisc_remnant !> Calculate the coupling coefficients (CS%a_u and CS%a_v) !! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the !! applying the implicit vertical viscosity via vertvisc(). -subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) +subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -579,7 +577,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure @@ -758,7 +756,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) + dt_in_T, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) if (allocated(hML_u)) then do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo endif @@ -773,7 +771,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then if (CS%harmonic_visc) then call find_coupling_coef(a_shelf, hvel, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & + kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, & visc, forces, work_on_u=.true., OBC=OBC, shelf=.true.) else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. @@ -801,7 +799,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif ; enddo enddo call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & + bbl_thick, kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, & visc, forces, work_on_u=.true., OBC=OBC, shelf=.true.) endif do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo @@ -927,7 +925,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) + dt_in_T, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) if ( allocated(hML_v)) then do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo endif @@ -941,7 +939,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then if (CS%harmonic_visc) then call find_coupling_coef(a_shelf, hvel, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, & + kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, visc, & forces, work_on_u=.false., OBC=OBC, shelf=.true.) else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. @@ -969,7 +967,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif ; enddo enddo call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & + bbl_thick, kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, & visc, forces, work_on_u=.false., OBC=OBC, shelf=.true.) endif do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo @@ -1034,7 +1032,7 @@ end subroutine vertvisc_coef !! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent !! layer thicknesses are used to calculate a_cpl near the bottom. subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) + dt_in_T, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1054,7 +1052,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, !! normalized by the bottom boundary layer thickness real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [H ~> m or kg m-2] integer, intent(in) :: j !< j-index to find coupling coefficient for - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces @@ -1107,7 +1105,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! The maximum coupling coefficent was originally introduced to avoid ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 ! sets the maximum coupling coefficient increment to 1e10 m per timestep. - I_amax = (1.0e-10*US%Z_to_m) * dt*US%s_to_T + I_amax = (1.0e-10*US%Z_to_m) * dt_in_T do_shelf = .false. ; if (present(shelf)) do_shelf = shelf do_OBCs = .false. @@ -1304,10 +1302,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, end subroutine find_coupling_coef -!> Velocity components which exceed a threshold for physically -!! reasonable values are truncated. Optionally, any column with excessive -!! velocities may be sent to a diagnostic reporting subroutine. -subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) +!> Velocity components which exceed a threshold for physically reasonable values +!! are truncated. Optionally, any column with excessive velocities may be sent +!! to a diagnostic reporting subroutine. +subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1321,14 +1319,13 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS type(cont_diag_ptrs), intent(in) :: CDp !< Continuity diagnostic pointers type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! Local variables real :: maxvel ! Velocities components greater than maxvel real :: truncvel ! are truncated to truncvel, both [L T-1 ~> m s-1]. - real :: dt_in_T ! The timestep [T ~> s] real :: CFL ! The local CFL number. real :: H_report ! A thickness below which not to report truncations. real :: dt_Rho0 ! The timestep divided by the Boussinesq density [s m3 kg-1]. @@ -1343,8 +1340,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS maxvel = CS%maxvel truncvel = 0.9*maxvel H_report = 6.0 * GV%Angstrom_H - dt_in_T = US%s_to_T*dt - dt_Rho0 = dt / GV%Rho0 + dt_Rho0 = US%T_to_s*dt_in_T / GV%Rho0 if (len_trim(CS%u_trunc_file) > 0) then !$OMP parallel do default(shared) private(trunc_any,CFL) @@ -1415,7 +1411,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS 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)) + 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 @@ -1426,7 +1422,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS do j=js,je; do I=Isq,Ieq ; if (dowrite(I,j)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. - call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + call write_u_accel(I, j, u_old, h, ADp, CDp, dt_in_T, G, GV, US, CS%PointAccel_CSp, & vel_report(I,j), forces%taux(I,j)*dt_Rho0, a=CS%a_u, hv=CS%h_u) endif ; enddo ; enddo endif @@ -1500,7 +1496,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS 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)) + 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 @@ -1511,7 +1507,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS do J=Jsq,Jeq; do i=is,ie ; if (dowrite(i,J)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. - call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + call write_v_accel(i, J, v_old, h, ADp, CDp, dt_in_T, G, GV, US, CS%PointAccel_CSp, & vel_report(i,J), forces%tauy(i,J)*dt_Rho0, a=CS%a_v, hv=CS%h_v) endif ; enddo ; enddo endif From 3704a665a3d9803d3be92c9b21f9b474d3e62844 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 11 Sep 2019 17:08:08 -0400 Subject: [PATCH 054/259] +Add density rescaling factors in unit_scale_type Added factors for power-of-2 rescaling of density to the unit_scale_type, along with the new run-time parameter R_RESCALE_POWER. All answers are bitwise identical, but there is a new runtime parameter, some new elements in a transparent public type, and a new optional variable in the MOM restart files. This adds a new entry to the MOM_parameter_doc.debugging files. --- src/core/MOM.F90 | 4 +++- src/framework/MOM_unit_scaling.F90 | 23 +++++++++++++++++++---- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8a5f9bfe02..0e5ca00823 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2558,7 +2558,7 @@ subroutine MOM_timing_init(CS) id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER) id_clock_continuity = cpu_clock_id('(Ocean continuity equation *)', grain=CLOCK_MODULE) - id_clock_BBL_visc = cpu_clock_id('(Ocean set BBL viscosity)', grain=CLOCK_MODULE) + id_clock_BBL_visc = cpu_clock_id('(Ocean set BBL viscosity)', grain=CLOCK_MODULE) id_clock_pass = cpu_clock_id('(Ocean message passing *)', grain=CLOCK_MODULE) id_clock_MOM_init = cpu_clock_id('(Ocean MOM_initialize_state)', grain=CLOCK_MODULE) id_clock_pass_init = cpu_clock_id('(Ocean init message passing *)', grain=CLOCK_ROUTINE) @@ -2644,6 +2644,8 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Length unit conversion factor", "L meter-1") call register_restart_field(US%s_to_T_restart, "s_to_T", .false., restart_CSp, & "Time unit conversion factor", "T second-1") + call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., restart_CSp, & + "Density unit conversion factor", "R m3 kg-1") end subroutine set_restart_fields diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index ca174025bf..fe7f95fc79 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -16,8 +16,10 @@ module MOM_unit_scaling real :: Z_to_m !< A constant that translates distances in the units of depth to meters. real :: m_to_L !< A constant that translates lengths in meters to the units of horizontal lengths. real :: L_to_m !< A constant that translates lengths in the units of horizontal lengths to meters. - real :: s_to_T !< A constant that time intervals in seconds to the units of time. - real :: T_to_s !< A constant that the units of time to seconds. + real :: s_to_T !< A constant that translates time intervals in seconds to the units of time. + real :: T_to_s !< A constant that translates the units of time to seconds. + real :: R_to_kg_m3 !< A constant that translates the units of density to kilograms per meter cubed. + real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density. ! These are useful combinations of the fundamental scale conversion factors above. real :: Z_to_L !< Convert vertical distances to lateral lengths @@ -32,6 +34,7 @@ module MOM_unit_scaling real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. real :: m_to_L_restart = 0.0 !< A copy of the m_to_L that is used in restart files. real :: s_to_T_restart = 0.0 !< A copy of the s_to_T that is used in restart files. + real :: kg_m3_to_R_restart = 0.0 !< A copy of the kg_m3_to_R that is used in restart files. end type unit_scale_type contains @@ -44,8 +47,8 @@ subroutine unit_scaling_init( param_file, US ) ! This routine initializes a unit_scale_type structure (US). ! Local variables - integer :: Z_power, L_power, T_power - real :: Z_rescale_factor, L_rescale_factor, T_rescale_factor + integer :: Z_power, L_power, T_power, R_power + real :: Z_rescale_factor, L_rescale_factor, T_rescale_factor, R_rescale_factor ! This include declares and sets the variable "version". # include "version_variable.h" character(len=16) :: mdl = "MOM_unit_scaling" @@ -69,12 +72,18 @@ subroutine unit_scaling_init( param_file, US ) "An integer power of 2 that is used to rescale the model's "//& "intenal units of time. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & + "An integer power of 2 that is used to rescale the model's "//& + "intenal units of density. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") if (abs(L_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "L_RESCALE_POWER is outside of the valid range of -300 to 300.") if (abs(T_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "T_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(R_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "R_RESCALE_POWER is outside of the valid range of -300 to 300.") Z_rescale_factor = 1.0 if (Z_power /= 0) Z_rescale_factor = 2.0**Z_power @@ -91,6 +100,11 @@ subroutine unit_scaling_init( param_file, US ) US%T_to_s = 1.0 * T_rescale_factor US%s_to_T = 1.0 / T_rescale_factor + R_rescale_factor = 1.0 + if (R_power /= 0) R_rescale_factor = 2.0**R_power + US%R_to_kg_m3 = 1.0 * R_rescale_factor + US%kg_m3_to_R = 1.0 / R_rescale_factor + ! These are useful combinations of the fundamental scale conversion factors set above. US%Z_to_L = US%Z_to_m * US%m_to_L US%L_to_Z = US%L_to_m * US%m_to_Z @@ -111,6 +125,7 @@ subroutine fix_restart_unit_scaling(US) US%m_to_Z_restart = US%m_to_Z US%m_to_L_restart = US%m_to_L US%s_to_T_restart = US%s_to_T + US%kg_m3_to_R_restart = US%kg_m3_to_R end subroutine fix_restart_unit_scaling From ff12685c3836a3fc2a5f8ad33a56fbc25d3e2274 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 11 Sep 2019 17:31:00 -0400 Subject: [PATCH 055/259] (+) Dimentional scaling fixes; H_to_MKS scaling This patch fixes the H dimensional scaling of several diagnostics. * h_preale * h_predia * Tflx_dia_diff * Tflx_dia_adv * Sflx_dia_diff * Sflx_dia_adv * diabatic_diff_h * boundary_forcing_h * frazil_h * internal_heat_h_tendency Two interface changes were introduced to complement these fixes. - The vertical grid struct (GV) was added to geothermal_init - We have introduced the H_to_MKS scaling factor, which is set to either H_to_m or H_to_kg_m2 based on whether the model is in Boussinesq mode. This to accommodate diagnostics whose units are based on the Boussinesq mode. The vert_remap_h diagnostic has also been partially rescaled and has been modified by this patch, but is not yet invariant to H scaling. --- src/ALE/MOM_ALE.F90 | 8 ++- src/core/MOM_verticalGrid.F90 | 4 ++ .../vertical/MOM_diabatic_driver.F90 | 63 +++++++++---------- .../vertical/MOM_geothermal.F90 | 10 ++- 4 files changed, 47 insertions(+), 38 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index def4148f25..63c0f027b0 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -250,7 +250,8 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) CS%id_v_preale = register_diag_field('ocean_model', 'v_preale', diag%axesCvL, Time, & 'Meridional velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_preale = register_diag_field('ocean_model', 'h_preale', diag%axesTL, Time, & - 'Layer Thickness before remapping', get_thickness_units(GV), v_extensive=.true.) + 'Layer Thickness before remapping', get_thickness_units(GV), & + conversion=GV%H_to_MKS, v_extensive=.true.) CS%id_T_preale = register_diag_field('ocean_model', 'T_preale', diag%axesTL, Time, & 'Temperature before remapping', 'degC') CS%id_S_preale = register_diag_field('ocean_model', 'S_preale', diag%axesTL, Time, & @@ -260,8 +261,9 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) CS%id_dzRegrid = register_diag_field('ocean_model','dzRegrid',diag%axesTi,Time, & 'Change in interface height due to ALE regridding', 'm') - cs%id_vert_remap_h = register_diag_field('ocean_model','vert_remap_h',diag%axestl,time, & - 'layer thicknesses after ALE regridding and remapping', 'm', v_extensive = .true.) + cs%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', & + diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', 'm', & + conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & 'Layer thicknesses tendency due to ALE regridding and remapping', 'm', v_extensive = .true.) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index c11de0d0dd..43c673a592 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -61,6 +61,8 @@ module MOM_verticalGrid real :: H_to_Pa !< A constant that translates the units of thickness to pressure [Pa]. real :: H_to_Z !< A constant that translates thickness units to the units of depth. real :: Z_to_H !< A constant that translates depth units to thickness units. + real :: H_to_MKS !< A constant that translates thickness units to its + !! MKS unit (m or kg m-2) based on GV%Boussinesq real :: m_to_H_restart = 0.0 !< A copy of the m_to_H that is used in restart files. end type verticalGrid_type @@ -143,11 +145,13 @@ subroutine verticalGridInit( param_file, GV, US ) GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = 1.0 / GV%H_to_m GV%Angstrom_H = GV%m_to_H * GV%Angstrom_m + GV%H_to_MKS = GV%H_to_m else GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = GV%Rho0 * GV%kg_m2_to_H GV%H_to_m = GV%H_to_kg_m2 / GV%Rho0 GV%Angstrom_H = GV%Angstrom_m*1000.0*GV%kg_m2_to_H + GV%H_to_MKS = GV%H_to_kg_m2 endif GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H,GV%m_to_H*1e-17) GV%H_to_Pa = GV%mks_g_Earth * GV%H_to_kg_m2 diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 2354fcf933..d6c38fa93e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -66,7 +66,7 @@ module MOM_diabatic_driver use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d -use MOM_verticalGrid, only : verticalGrid_type +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS @@ -508,10 +508,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC m s-1] - Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC m s-1] - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt m s-1] - Sadv_flx ! advective diapycnal salt flux across interfaces [ppt m s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, ! where massive is defined as sufficiently thick that @@ -1291,10 +1291,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC m s-1] - Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC m s-1] - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt m s-1] - Sadv_flx ! advective diapycnal salt flux across interfaces [ppt m s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, ! where massive is defined as sufficiently thick that @@ -2705,7 +2705,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) do j=js,je do K=2,nz ; do i=is,ie - CDp%diapyc_vel(i,j,K) = Idt * (GV%H_to_m * (ea(i,j,k) - eb(i,j,k-1))) + CDp%diapyc_vel(i,j,K) = Idt * (ea(i,j,k) - eb(i,j,k-1)) enddo ; enddo do i=is,ie CDp%diapyc_vel(i,j,1) = 0.0 @@ -3203,7 +3203,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di real :: Kd integer :: num_mode logical :: use_temperature, differentialDiffusion - real :: H_to_MKS !< Conversion factor from H to equivalent MKS unit ! This "include" declares and sets the variable "version". #include "version_variable.h" @@ -3362,22 +3361,20 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Register all available diagnostics for this module. - if (GV%Boussinesq) then - thickness_units = "m" - H_to_MKS = GV%H_to_m - else - thickness_units = "kg m-2" - H_to_MKS = GV%H_to_kg_m2 - endif + thickness_units = get_thickness_units(GV) CS%id_ea_t = register_diag_field('ocean_model','ea_t',diag%axesTL,Time, & - 'Layer (heat) entrainment from above per timestep','m') + 'Layer (heat) entrainment from above per timestep','m', & + conversion=GV%H_to_m) CS%id_eb_t = register_diag_field('ocean_model','eb_t',diag%axesTL,Time, & - 'Layer (heat) entrainment from below per timestep', 'm') + 'Layer (heat) entrainment from below per timestep', 'm', & + conversion=GV%H_to_m) CS%id_ea_s = register_diag_field('ocean_model','ea_s',diag%axesTL,Time, & - 'Layer (salt) entrainment from above per timestep','m') + 'Layer (salt) entrainment from above per timestep','m', & + conversion=GV%H_to_m) CS%id_eb_s = register_diag_field('ocean_model','eb_s',diag%axesTL,Time, & - 'Layer (salt) entrainment from below per timestep', 'm') + 'Layer (salt) entrainment from below per timestep', 'm', & + conversion=GV%H_to_m) ! used by layer diabatic CS%id_ea = register_diag_field('ocean_model','ea',diag%axesTL,Time, & 'Layer entrainment from above per timestep','m', & @@ -3410,16 +3407,16 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (use_temperature) then CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff",diag%axesTi, & Time, "Diffusive diapycnal temperature flux across interfaces", & - "degC m s-1") + "degC m s-1", conversion=GV%H_to_m) CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv",diag%axesTi, & Time, "Advective diapycnal temperature flux across interfaces", & - "degC m s-1") + "degC m s-1", conversion=GV%H_to_m) CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff",diag%axesTi, & Time, "Diffusive diapycnal salnity flux across interfaces", & - "psu m s-1") + "psu m s-1", conversion=GV%H_to_m) CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv",diag%axesTi, & Time, "Advective diapycnal salnity flux across interfaces", & - "psu m s-1") + "psu m s-1", conversion=GV%H_to_m) CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & 'Mixed layer depth (delta rho = 0.03)', 'm', conversion=US%Z_to_m, & cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & @@ -3454,8 +3451,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_v_predia = register_diag_field('ocean_model', 'v_predia', diag%axesCvL, Time, & 'Meridional velocity before diabatic forcing', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_predia = register_diag_field('ocean_model', 'h_predia', diag%axesTL, Time, & - 'Layer Thickness before diabatic forcing', thickness_units, v_extensive=.true., & - conversion=H_to_MKS) + 'Layer Thickness before diabatic forcing', trim(thickness_units), & + conversion=GV%H_to_MKS, v_extensive=.true.) CS%id_e_predia = register_diag_field('ocean_model', 'e_predia', diag%axesTi, Time, & 'Interface Heights before diabatic forcing', 'm') if (use_temperature) then @@ -3519,7 +3516,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & - long_name = 'Cell thickness used during diabatic diffusion', units='m', v_extensive=.true.) + long_name = 'Cell thickness used during diabatic diffusion', units='m', & + conversion=GV%H_to_m, v_extensive=.true.) if (CS%useALEalgorithm) then CS%id_diabatic_diff_temp_tend = register_diag_field('ocean_model', & 'diabatic_diff_temp_tendency', diag%axesTL, Time, & @@ -3591,7 +3589,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & - long_name = 'Cell thickness after applying boundary forcing', units='m', v_extensive=.true.) + long_name = 'Cell thickness after applying boundary forcing', units='m', & + conversion=GV%H_to_m, v_extensive=.true.) CS%id_boundary_forcing_h_tendency = register_diag_field('ocean_model', & 'boundary_forcing_h_tendency', diag%axesTL, Time, & 'Cell thickness tendency due to boundary forcing', 'm s-1', & @@ -3650,7 +3649,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! diagnostics for tendencies of temp and heat due to frazil CS%id_frazil_h = register_diag_field('ocean_model', 'frazil_h', diag%axesTL, Time, & long_name = 'Cell Thickness', standard_name='cell_thickness', units='m', & - v_extensive=.true., conversion=GV%H_to_m) + conversion=GV%H_to_m, v_extensive=.true.) ! diagnostic for tendency of temp due to frazil CS%id_frazil_temp_tend = register_diag_field('ocean_model',& @@ -3693,7 +3692,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! initialize the geothermal heating module if (CS%use_geothermal) & - call geothermal_init(Time, G, param_file, diag, CS%geothermal_CSp) + call geothermal_init(Time, G, GV, param_file, diag, CS%geothermal_CSp) ! initialize module for internal tide induced mixing if (CS%use_int_tides) then diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index d3d0f2bc6e..5fefbf199e 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -11,7 +11,7 @@ module MOM_geothermal use MOM_io, only : MOM_read_data, slasher use MOM_grid, only : ocean_grid_type use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_EOS, only : calculate_density, calculate_density_derivs implicit none ; private @@ -371,9 +371,10 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) end subroutine geothermal !> Initialize parameters and allocate memory associated with the geothermal heating module. -subroutine geothermal_init(Time, G, param_file, diag, CS) +subroutine geothermal_init(Time, G, GV, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: 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 to parse for run-time !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< Structure used to regulate diagnostic output. @@ -382,6 +383,7 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_geothermal" ! module name + character(len=48) :: thickness_units ! Local variables character(len=200) :: inputdir, geo_file, filename, geotherm_var real :: scale @@ -442,6 +444,8 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) endif call pass_var(CS%geo_heat, G%domain) + thickness_units = get_thickness_units(GV) + ! post the static geothermal heating field id = register_static_field('ocean_model', 'geo_heat', diag%axesT1, & 'Geothermal heat flux into ocean', 'W m-2', & @@ -463,7 +467,7 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) CS%id_internal_heat_h_tendency=register_diag_field('ocean_model', & 'internal_heat_h_tendency', diag%axesTL, Time, & 'Thickness tendency (in 3D) due to internal (geothermal) sources', & - 'm OR kg m-2', v_extensive=.true.) + trim(thickness_units), conversion=GV%H_to_MKS, v_extensive=.true.) end subroutine geothermal_init From f1b866da3b12457a25baf4ef776c43536637ab7c Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 12 Sep 2019 11:50:57 -0400 Subject: [PATCH 056/259] Diagnostic scaling; global_spatial_mean in MKS The dimensional scaling of three diagnostics has been amended: * dzRegrid * vert_remap_h_tendency * wd The spatial averaging function global_spatial_mean has also been modified to run entirely in MKS units, due to the reproducing_sum function requirement. A previous change fixed a bug in this function, where only part of the solution was being scaled. This new fix restores the original scaling, but de-scales the final result in order to retain reproducibility. --- src/ALE/MOM_ALE.F90 | 6 ++++-- src/framework/MOM_spatial_means.F90 | 8 ++++---- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 63c0f027b0..8eed4aa925 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -260,12 +260,14 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) 'Interface Heights before remapping', 'm', conversion=US%Z_to_m) CS%id_dzRegrid = register_diag_field('ocean_model','dzRegrid',diag%axesTi,Time, & - 'Change in interface height due to ALE regridding', 'm') + 'Change in interface height due to ALE regridding', 'm', & + conversion=GV%H_to_m) cs%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', & diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', 'm', & conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & - 'Layer thicknesses tendency due to ALE regridding and remapping', 'm', v_extensive = .true.) + 'Layer thicknesses tendency due to ALE regridding and remapping', 'm', & + conversion=GV%H_to_m, v_extensive = .true.) end subroutine ALE_register_diags diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index f6282faa52..5a84ca0001 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -36,9 +36,9 @@ function global_area_mean(var,G) tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie - tmpForSumming(i,j) = var(i,j) * (G%areaT(i,j) * G%mask2dT(i,j)) + tmpForSumming(i,j) = var(i,j) * (G%US%L_to_m**2 * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo - global_area_mean = reproducing_sum( tmpForSumming ) * G%IareaT_global + global_area_mean = reproducing_sum(tmpForSumming) * (G%US%m_to_L**2 * G%IareaT_global) end function global_area_mean @@ -54,9 +54,9 @@ function global_area_integral(var,G) tmpForSumming(:,:) = 0. do j=js,je ; do i=is, ie - tmpForSumming(i,j) = ( var(i,j) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) ) + tmpForSumming(i,j) = var(i,j) * (G%US%L_to_m**2 * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo - global_area_integral = reproducing_sum( tmpForSumming ) + global_area_integral = reproducing_sum(tmpForSumming) end function global_area_integral diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index d6c38fa93e..369ee5da40 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3383,7 +3383,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Layer entrainment from below per timestep', 'm', & conversion=GV%H_to_m) CS%id_wd = register_diag_field('ocean_model','wd',diag%axesTi,Time, & - 'Diapycnal velocity', 'm s-1') + 'Diapycnal velocity', 'm s-1', conversion=GV%H_to_m) if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) CS%id_dudt_dia = register_diag_field('ocean_model','dudt_dia',diag%axesCuL,Time, & From 5274403ec806b4187d2e8219ab1dd12048068805 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 12 Sep 2019 18:00:28 -0400 Subject: [PATCH 057/259] +Add H_to_RZ and RZ_to_H to the verticalGrid_type Added two new dimensional conversion factors, H_to_RZ and RZ_to_H, to the MOM6 vertical grid, in preparation for adding testing of dimensional rescaling of density to the MOM6 code. All answers are bitwise identical, but a transparent type has two new elements. --- src/core/MOM_verticalGrid.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index c11de0d0dd..66ff737bff 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -61,6 +61,8 @@ module MOM_verticalGrid real :: H_to_Pa !< A constant that translates the units of thickness to pressure [Pa]. real :: H_to_Z !< A constant that translates thickness units to the units of depth. real :: Z_to_H !< A constant that translates depth units to thickness units. + real :: H_to_RZ !< A constant that translates thickness units to the units of mass per unit area. + real :: RZ_to_H !< A constant that translates mass per unit area units to thickness units. real :: m_to_H_restart = 0.0 !< A copy of the m_to_H that is used in restart files. end type verticalGrid_type @@ -156,6 +158,9 @@ subroutine verticalGridInit( param_file, GV, US ) GV%Z_to_H = US%Z_to_m * GV%m_to_H GV%Angstrom_Z = US%m_to_Z * GV%Angstrom_m + GV%H_to_RZ = GV%H_to_kg_m2 * US%kg_m3_to_R * US%m_to_Z + GV%RZ_to_H = GV%kg_m2_to_H * US%R_to_kg_m3 * US%Z_to_m + ! Log derivative values. call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*H_rescale_factor) call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H) From 8eaa01c1764dee1b212ef7f70c374f0947332775 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 13 Sep 2019 11:52:19 -0400 Subject: [PATCH 058/259] Rescaled density units in MOM_bulk_mixedlayer Rescaled density units in MOM_bulk_mixedlayer for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_bulk_mixed_layer.F90 | 176 +++++++++--------- 1 file changed, 92 insertions(+), 84 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 2a17bfbd6f..ea7a740df5 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -131,9 +131,9 @@ module MOM_bulk_mixed_layer diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer. diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2. diag_PE_detrain, & !< The spurious source of potential energy due to mixed layer - !! detrainment [kg T-3 Z m-1 ~> W m-2]. + !! detrainment [R Z L2 T-3 ~> W m-2]. diag_PE_detrain2 !< The spurious source of potential energy due to mixed layer only - !! detrainment [kg T-3 Z m-1 ~> W m-2]. + !! detrainment [R Z L2 T-3 ~> W m-2]. logical :: allow_clocks_in_omp_loops !< If true, clocks can be called from inside loops that can !! be threaded. To run with multiple threads, set to False. type(group_pass_type) :: pass_h_sum_hmbl_prev !< For group halo pass @@ -244,8 +244,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, h, & ! The layer thickness [H ~> m or kg m-2]. T, & ! The layer temperatures [degC]. S, & ! The layer salinities [ppt]. - R0, & ! The potential density referenced to the surface [kg m-3]. - Rcv ! The coordinate variable potential density [kg m-3]. + R0, & ! The potential density referenced to the surface [R ~> kg m-3]. + Rcv ! The coordinate variable potential density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)) :: & u, & ! The zonal velocity [L T-1 ~> m s-1]. v, & ! The meridional velocity [L T-1 ~> m s-1]. @@ -269,9 +269,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, htot, & ! The total depth of the layers being considered for ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface - ! of the layers which are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. Rcv_tot, & ! The integrated coordinate value potential density of the - ! layers that are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully ! entrained [degC H ~> degC m or degC kg m-2]. Stot, & ! The integrated salt of layers which are fully entrained @@ -293,13 +293,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, p_ref_cv, & ! Reference pressure for the potential density which defines ! the coordinate variable, set to P_Ref [Pa]. dR0_dT, & ! Partial derivative of the mixed layer potential density with - ! temperature [kg m-3 degC-1]. + ! temperature [R degC-1 ~> kg m-3 degC-1]. dRcv_dT, & ! Partial derivative of the coordinate variable potential - ! density in the mixed layer with temperature [kg m-3 degC-1]. + ! density in the mixed layer with temperature [R degC-1 ~> kg m-3 degC-1]. dR0_dS, & ! Partial derivative of the mixed layer potential density with - ! salinity [kg m-3 ppt-1]. + ! salinity [R ppt-1 ~> kg m-3 ppt-1]. dRcv_dS, & ! Partial derivative of the coordinate variable potential - ! density in the mixed layer with salinity [kg m-3 ppt-1]. + ! density in the mixed layer with salinity [R ppt-1 ~> kg m-3 ppt-1]. TKE_river ! The source of turbulent kinetic energy available for mixing ! at rivermouths [Z L2 T-3 ~> m3 s-3]. @@ -312,7 +312,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, real :: cMKE(2,SZI_(G)) ! Coefficients of HpE and HpE^2 used in calculating the ! denominator of MKE_rate; the two elements have differing ! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. - real :: Irho0 ! 1.0 / rho_0 [m3 kg-1] + real :: Irho0 ! 1.0 / rho_0 [R-1 ~> m3 kg-1] real :: Inkml, Inkmlm1! 1.0 / REAL(nkml) and 1.0 / REAL(nkml-1) real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. @@ -372,7 +372,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, ! dt_in_T = dt * US%s_to_T - Irho0 = 1.0 / GV%Rho0 + Irho0 = 1.0 / (US%kg_m3_to_R*GV%Rho0) dt__diag = dt_in_T ; if (present(dt_diag)) dt__diag = dt_diag Idt_diag = 1.0 / (dt__diag) write_diags = .true. ; if (present(last_call)) write_diags = last_call @@ -471,11 +471,19 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, is, ie-is+1, tv%eqn_of_state) call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, & is, ie-is+1, tv%eqn_of_state) + if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie + dR0_dT(i) = US%kg_m3_to_R * dR0_dT(i) ; dR0_dS(i) = US%kg_m3_to_R * dR0_dS(i) + dRcv_dT(i) = US%kg_m3_to_R * dRcv_dT(i) ; dRcv_dS(i) = US%kg_m3_to_R * dRcv_dS(i) + enddo ; endif do k=1,nz call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), is, ie-is+1, & tv%eqn_of_state) call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & ie-is+1, tv%eqn_of_state) + if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie + R0(i,k) = US%kg_m3_to_R * R0(i,k) + Rcv(i,k) = US%kg_m3_to_R * Rcv(i,k) + enddo ; endif enddo if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) @@ -517,7 +525,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, RmixConst = 0.5*CS%rivermix_depth * (GV%g_Earth*US%m_to_Z) * Irho0**2 do i=is,ie TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & - US%T_to_s*(fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + US%T_to_s*US%kg_m3_to_R*(fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) enddo else do i=is,ie ; TKE_river(i) = 0.0 ; enddo @@ -606,7 +614,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, if (CS%ML_resort) then if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) - call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay, eps, & + call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), US%kg_m3_to_R*GV%Rlay(:), eps, & d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) endif @@ -642,11 +650,11 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, if (id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) if (CS%nkbl == 1) then call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & - GV%Rlay, dt_in_T, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & + US%kg_m3_to_R*GV%Rlay(:), dt_in_T, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & dRcv_dT, dRcv_dS, max_BL_det) elseif (CS%nkbl == 2) then call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & - GV%Rlay, dt_in_T, dt__diag, d_ea, j, G, GV, US, CS, & + US%kg_m3_to_R*GV%Rlay(:), dt_in_T, dt__diag, d_ea, j, G, GV, US, CS, & dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) else ! CS%nkbl not = 1 or 2 ! This code only works with 1 or 2 buffer layers. @@ -814,9 +822,9 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: T !< Layer temperatures [degC]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [ppt]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure [kg m-3]. + !! surface pressure [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Rcv !< The coordinate defining potential - !! density [kg m-3]. + !! density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a layer !! in the entrainment from below [H ~> m or kg m-2]. !! Positive values go with mass gain by @@ -845,9 +853,9 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & htot, & ! The total depth of the layers being considered for ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface - ! of the layers which are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. Rcv_tot, & ! The integrated coordinate value potential density of the - ! layers that are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully ! entrained [degC H ~> degC m or degC kg m-2]. Stot, & ! The integrated salt of layers which are fully entrained @@ -861,11 +869,11 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of ! the conversion from H to Z divided by the mean density, - ! in [L2 Z m3 T-3 H-2 kg-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! in [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. integer :: is, ie, nz, i, k, k1, nzc, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * US%kg_m3_to_R*GV%Rho0) nzc = nz ; if (present(nz_conv)) nzc = nz_conv nkmb = CS%nkml+CS%nkbl @@ -959,9 +967,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G)), intent(out) :: vhtot !< The integrated mixed layer meridional !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(out) :: R0_tot !< The integrated mixed layer potential density referenced - !! to 0 pressure [H kg m-2 ~> kg m-1 or kg2 m-4]. + !! to 0 pressure [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G)), intent(out) :: Rcv_tot !< The integrated mixed layer coordinate - !! variable potential density [H kg m-2 ~> kg m-1 or kg2 m-4]. + !! variable potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: u !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK_(GV)), & @@ -972,21 +980,21 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & intent(in) :: S !< Layer salinities [ppt]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: R0 !< Potential density referenced to - !! surface pressure [kg m-3]. + !! surface pressure [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: Rcv !< The coordinate defining potential - !! density [kg m-3]. + !! density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: eps !< The negligibly small amount of water !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to - !! temperature [kg m-3 degC-1]. + !! temperature [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to - !! temperature [kg m-3 degC-1]. + !! temperature [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of R0 with respect to - !! salinity [kg m-3 ppt-1]. + !! salinity [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of Rcv with respect to - !! salinity [kg m-3 ppt-1]. + !! salinity [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: netMassInOut !< The net mass flux (if non-Boussinesq) !! or volume flux (if Boussinesq) into the ocean !! within a time step [H ~> m or kg m-2]. (I.e. P+R-E.) @@ -1043,9 +1051,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: T_precip ! The temperature of the precipitation [degC]. real :: C1_3, C1_6 ! 1/3 and 1/6. real :: En_fn, Frac, x1 ! Nondimensional temporary variables. - real :: dr, dr0 ! Temporary variables [kg m-3 H ~> kg m-2 or kg2 m-5]. - real :: dr_ent, dr_comp ! Temporary variables [kg m-3 H ~> kg m-2 or kg2 m-5]. - real :: dr_dh ! The partial derivative of dr_ent with h_ent [kg m-3]. + real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. + real :: dr_ent, dr_comp ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. + real :: dr_dh ! The partial derivative of dr_ent with h_ent [R ~> kg m-3]. real :: h_min, h_max ! The minimum, maximum, and previous estimates for real :: h_prev ! h_ent [H ~> m or kg m-2]. real :: h_evap ! The thickness that is evaporated [H ~> m or kg m-2]. @@ -1053,22 +1061,22 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! h_ent between iterations [H ~> m or kg m-2]. real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of ! the conversion from H to Z divided by the mean density, - ! [L2 Z m3 T-3 H-2 kg-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. real :: opacity ! The opacity converted to inverse thickness units [H-1 ~> m-1 or m2 kg-1] real :: sum_Pen_En ! The potential energy change due to penetrating ! shortwave radiation, integrated over a layer - ! [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! [H R ~> kg m-2 or kg2 m-5]. real :: Idt ! 1.0/dt [T-1 ~> s-1] real :: netHeatOut ! accumulated heat content of mass leaving ocean integer :: is, ie, nz, i, k, ks, itt, n real, dimension(max(nsw,1)) :: & - C2, & ! Temporary variable [kg m-3 H-1 ~> kg m-4 or m-1]. - r_SW_top ! Temporary variables [H kg m-3 ~> kg m-2 or kg2 m-5]. + C2, & ! Temporary variable R H-1 ~> kg m-4 or m-1]. + r_SW_top ! Temporary variables [H R ~> kg m-2 or kg2 m-5]. Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * US%kg_m3_to_R*GV%Rho0) Idt = 1.0 / dt_in_T is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1514,9 +1522,9 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G)), intent(inout) :: vhtot !< The integrated mixed layer meridional !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(inout) :: R0_tot !< The integrated mixed layer potential density - !! referenced to 0 pressure [H kg m-3 ~> kg m-2 or kg2 m-5]. + !! referenced to 0 pressure [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G)), intent(inout) :: Rcv_tot !< The integrated mixed layer coordinate variable - !! potential density [H kg m-3 ~> kg m-2 or kg2 m-5]. + !! potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: u !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK_(GV)), & @@ -1527,17 +1535,17 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & intent(in) :: S !< Layer salinities [ppt]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: R0 !< Potential density referenced to - !! surface pressure [kg m-3]. + !! surface pressure [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: Rcv !< The coordinate defining potential - !! density [kg m-3]. + !! density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: eps !< The negligibly small amount of water !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to - !! temperature [kg m-3 degC-1]. + !! temperature [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to - !! temperature [kg m-3 degC-1]. + !! temperature [R degC-1 ~> kg m-3 degC-1]. real, dimension(2,SZI_(G)), intent(in) :: cMKE !< Coefficients of HpE and HpE^2 used in calculating the !! denominator of MKE_rate; the two elements have differing !! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. @@ -1577,7 +1585,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: HpE ! The current thickness plus entrainment [H ~> m or kg m-2]. real :: g_H_2Rho0 ! Half the gravitational acceleration times the ! conversion from H to m divided by the mean density, - ! in [L2 m3 T-2 H-1 kg-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: TKE_full_ent ! The TKE remaining if a layer is fully entrained ! [Z L2 T-2 ~> m3 s-2]. real :: dRL ! Work required to mix water from the next layer @@ -1611,7 +1619,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & integer :: is, ie, nz, i, k, ks, itt, n C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 ; C1_24 = 1.0/24.0 - g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * US%kg_m3_to_R*GV%Rho0) Hmix_min = CS%Hmix_min h_neglect = GV%H_subroundoff is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1837,7 +1845,7 @@ subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: R0 !< The potential density used to sort - !! the layers [kg m-3]. + !! the layers [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The (small) thickness that must !! remain in each layer [H ~> m or kg m-2]. type(bulkmixedlayer_CS), pointer :: CS !< The control structure returned by a @@ -1893,11 +1901,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [degC]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure [kg m-3]. + !! surface pressure [R ~> kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining - !! potential density [kg m-3]. + !! potential density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each - !! layer [kg m-3]. + !! layer [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: eps !< The (small) thickness that must !! remain in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a @@ -1915,19 +1923,19 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced !! to the surface with potential - !! temperature [kg m-3 degC-1]. + !! temperature [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of !! cpotential density referenced !! to the surface with salinity, - !! [kg m-3 ppt-1]. + !! [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential !! density with potential - !! temperature [kg m-3 degC-1]. + !! temperature [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential !! density with salinity, - !! [kg m-3 ppt-1]. + !! [R ppt-1 ~> kg m-3 ppt-1]. ! If there are no massive light layers above the deepest of the mixed- and ! buffer layers, do nothing (except perhaps to reshuffle these layers). @@ -2213,11 +2221,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [degC]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure [kg m-3]. + !! surface pressure [R ~> kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential - !! density [kg m-3]. + !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each - !! layer [kg m-3]. + !! layer [R ~> kg m-3]. real, intent(in) :: dt_in_T !< Time increment [T ~> s]. real, intent(in) :: dt_diag !< The diagnostic time step [T ~> s]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a layer in @@ -2231,18 +2239,18 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced to the !! surface with potential temperature, - !! [kg m-3 degC-1]. + !! [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of !! cpotential density referenced to the !! surface with salinity - !! [kg m-3 ppt-1]. + !! [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature, - !! [kg m-3 degC-1]. + !! [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential density - !! with salinity [kg m-3 ppt-1]. + !! with salinity [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum !! detrainment permitted from the buffer !! layers [H ~> m or kg m-2]. @@ -2255,9 +2263,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real :: h_to_bl ! The total thickness detrained to the buffer ! layers [H ~> m or kg m-2]. real :: R0_to_bl ! The depth integrated amount of R0 that is detrained to the - ! buffer layer [H kg m-3 ~> kg m-2 or kg2 m-5] + ! buffer layer [H R ~> kg m-2 or kg2 m-5] real :: Rcv_to_bl ! The depth integrated amount of Rcv that is detrained to the - ! buffer layer [H kg m-3 ~> kg m-2 or kg2 m-5] + ! buffer layer [H R ~> kg m-2 or kg2 m-5] real :: T_to_bl ! The depth integrated amount of T that is detrained to the ! buffer layer [degC H ~> degC m or degC kg m-2] real :: S_to_bl ! The depth integrated amount of S that is detrained to the @@ -2282,7 +2290,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea ! layer that remains [H ~> m or kg m-2]. real :: stays_min_merge ! The minimum allowed value of stays_merge [H ~> m or kg m-2]. - real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [kg m-3 H-1 ~> kg m-4 or m-1] + real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [R H-1 ~> kg m-4 or m-1] ! real :: dT_2dz, dS_2dz ! Half the vertical gradients of T and S, in degC H-1, and ppt H-1. real :: scale_slope ! A nondimensional number < 1 used to scale down ! the slope within the upper buffer layer when @@ -2293,7 +2301,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea ! rho_0*g [H2 ~> m2 or kg2 m-4]. real :: dPE_det, dPE_merge ! The energy required to mix the detrained water ! into the buffer layer or the merge the two - ! buffer layers [kg H2 Z T-2 L-2 m-1 ~> J m-2 or J kg2 m-8]. + ! buffer layers [R H2 L2 Z-1 T-2 ~> J m-2 or J kg2 m-8]. real :: h_from_ml ! The amount of additional water that must be ! drawn from the mixed layer [H ~> m or kg m-2]. @@ -2308,18 +2316,18 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea ! interior layers that are just lighter and ! just denser than the lower buffer layer. - real :: R0_det, T_det, S_det ! Detrained values of R0 [kg m-3], T [degC], and S [ppt]. + real :: R0_det, T_det, S_det ! Detrained values of R0 [R ~> kg m-3], T [degC], and S [ppt]. real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer. real :: T_stays, S_stays ! Values of T and S that stay in a layer. real :: dSpice_det, dSpice_stays! The spiciness difference between an original ! buffer layer and the water that moves into ! an interior layer or that stays in that - ! layer [kg m-3]. + ! layer [R ~> kg m-3]. real :: dSpice_lim, dSpice_lim2 ! Limits to the spiciness difference between ! the lower buffer layer and the water that - ! moves into an interior layer [kg m-3]. + ! moves into an interior layer [R ~> kg m-3]. real :: dSpice_2dz ! The vertical gradient of spiciness used for - ! advection [kg m-3 H-1 ~> kg m-4 or m-1]. + ! advection [R H-1 ~> kg m-4 or m-1]. real :: dPE_ratio ! Multiplier of dPE_det at which merging is ! permitted - here (detrainment_per_day/dt)*30 @@ -2333,8 +2341,8 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real :: I_denom ! A work variable with units of [ppt2 m6 kg-2]. real :: g_2 ! 1/2 g_Earth [L2 Z-1 T-2 ~> m s-2]. - real :: Rho0xG ! Rho0 times G_Earth [kg L2 m-3 Z-1 T-2 ~> kg m-2 s-2]. - real :: I2Rho0 ! 1 / (2 Rho0) [m3 kg-1]. + real :: Rho0xG ! Rho0 times G_Earth [R L2 Z-1 T-2 ~> kg m-2 s-2]. + real :: I2Rho0 ! 1 / (2 Rho0) [R-1 ~> m3 kg-1]. real :: Idt_H2 ! The square of the conversion from thickness to Z ! divided by the time step [Z2 H-2 T-1 ~> s-1 or m6 kg-2 s-1]. logical :: stable_Rcv ! If true, the buffer layers are stable with @@ -2349,7 +2357,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real :: Ih, Ihdet, Ih1f, Ih2f ! Assorted inverse thickness work variables, real :: Ihk0, Ihk1, Ih12 ! all in [H-1 ~> m-1 or m2 kg-1]. real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables, - real :: dR0, dR21, dRcv ! all in [kg m-3]. + real :: dR0, dR21, dRcv ! all in [R ~> kg m-3]. real :: dRcv_stays, dRcv_det, dRcv_lim real :: Angstrom ! The minumum layer thickness [H ~> m or kg m-2]. @@ -2362,9 +2370,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea nkmb = CS%nkml+CS%nkbl h_neglect = GV%H_subroundoff g_2 = 0.5 * GV%g_Earth - Rho0xG = GV%Rho0 * GV%g_Earth + Rho0xG = US%kg_m3_to_R*GV%Rho0 * GV%g_Earth Idt_H2 = GV%H_to_Z**2 / dt_diag - I2Rho0 = 0.5 / GV%Rho0 + I2Rho0 = 0.5 / (US%kg_m3_to_R*GV%Rho0) Angstrom = GV%Angstrom_H ! This is hard coding of arbitrary and dimensional numbers. @@ -2802,7 +2810,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & (R0_det-R0(i,0))*h_det_to_h2 ) + & - h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap ) + h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*US%kg_m3_to_R*GV%Rho0*dPE_extrap ) if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + s1en @@ -3104,11 +3112,11 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [degC]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure [kg m-3]. + !! surface pressure [R ~> kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential - !! density [kg m-3]. + !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each - !! layer [kg m-3]. + !! layer [R ~> kg m-3]. real, intent(in) :: dt_in_T !< Time increment [T ~> s]. real, intent(in) :: dt_diag !< The accumulated time interval for !! diagnostics [T ~> s]. @@ -3127,10 +3135,10 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature - !! [kg m-3 degC-1]. + !! [R degC-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential density - !! with salinity [kg m-3 ppt-1]. + !! with salinity [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum !! detrainment permitted from the buffer !! layers [H ~> m or kg m-2]. @@ -3148,7 +3156,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the square of the ! conversion from H to m divided by the mean density times the time - ! step [L2 Z m3 T-3 H-2 kg-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! step [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. real :: g_H2_2dt ! Half the gravitational acceleration times the square of the ! conversion from H to Z divided by the diagnostic time step ! [L2 Z H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. @@ -3163,7 +3171,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea "CS%nkbl must be 1 in mixedlayer_detrain_1.") dt_Time = dt_in_T / CS%BL_detrain_time - g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0 * dt_diag) + g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * US%kg_m3_to_R*GV%Rho0 * dt_diag) g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) ! Move detrained water into the buffer layer. @@ -3606,10 +3614,10 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer detrainment', & - 'W m-2', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain2 = register_diag_field('ocean_model', 'PE_detrain2', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer only detrainment', & - 'W m-2', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_h_mismatch = register_diag_field('ocean_model', 'h_miss_ML', diag%axesT1, & Time, 'Summed absolute mismatch in entrainment terms', 'm', conversion=US%Z_to_m) CS%id_Hsfc_used = register_diag_field('ocean_model', 'Hs_used', diag%axesT1, & From 00609e8713e63eb1256e2aa8e83f0a9521a46b61 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 13 Sep 2019 16:56:54 -0400 Subject: [PATCH 059/259] New parameter indicating sponge data are ongrid -A new parameter (SPONGE_DATA_ONGRID) which can be used to indicate that input sponge data reside on the model horizontal grid --- src/framework/MOM_horizontal_regridding.F90 | 247 +++++++++--------- .../MOM_state_initialization.F90 | 4 +- .../vertical/MOM_ALE_sponge.F90 | 16 +- 3 files changed, 146 insertions(+), 121 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 0cb670197d..8d3b7082b1 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -600,7 +600,7 @@ end subroutine horiz_interp_and_extrap_tracer_record !> Extrapolate and interpolate using a FMS time interpolation handle subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, & z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, m_to_Z) + tripolar_n, homogenize, spongeOngrid, m_to_Z) integer, intent(in) :: fms_id !< A unique id used by the FMS time interpolator type(time_type), intent(in) :: Time !< A FMS time type @@ -617,6 +617,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions + logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units !! of depth. If missing, G%bathyT must be in m. @@ -649,6 +650,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t integer, dimension(4) :: fld_sz character(len=12) :: dim_name(4) logical :: debug=.false. + logical :: spongeDataOngrid real :: npoints,varAvg real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out, tr_out, mask_out real, dimension(SZI_(G),SZJ_(G)) :: good, fill @@ -662,7 +664,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) - PI_180=atan(1.0)/45. ! Open NetCDF file and if present, extract data and spatial coordinate information @@ -671,7 +672,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_begin(id_clock_read) fld_sz = get_external_field_size(fms_id) - if (allocated(lon_in)) deallocate(lon_in) if (allocated(lat_in)) deallocate(lat_in) if (allocated(z_in)) deallocate(z_in) @@ -682,11 +682,19 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t axes_data = get_external_field_axes(fms_id) id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3) - allocate(lon_in(id),lat_in(jd),z_in(kd),z_edges_in(kd+1)) + + spongeDataOngrid=.false. + if (PRESENT(spongeOngrid)) spongeDataOngrid=spongeOngrid + if (.not. spongeDataOngrid) then + allocate(lon_in(id),lat_in(jd)) + call mpp_get_axis_data(axes_data(1), lon_in) + call mpp_get_axis_data(axes_data(2), lat_in) + endif + + allocate(z_in(kd),z_edges_in(kd+1)) + allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) - call mpp_get_axis_data(axes_data(1), lon_in) - call mpp_get_axis_data(axes_data(2), lat_in) call mpp_get_axis_data(axes_data(3), z_in) if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif @@ -695,47 +703,44 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t missing_value = get_external_field_missing(fms_id) - -! extrapolate the input data to the north pole using the northerm-most latitude - - max_lat = maxval(lat_in) - add_np=.false. - if (max_lat < 90.0) then - add_np = .true. - jdp = jd+1 - allocate(lat_inp(jdp)) - lat_inp(1:jd) = lat_in(:) - lat_inp(jd+1) = 90.0 - deallocate(lat_in) - allocate(lat_in(1:jdp)) - lat_in(:) = lat_inp(:) + if (.not. spongeDataOngrid) then + ! extrapolate the input data to the north pole using the northerm-most latitude + max_lat = maxval(lat_in) + add_np=.false. + if (max_lat < 90.0) then + add_np = .true. + jdp = jd+1 + allocate(lat_inp(jdp)) + lat_inp(1:jd) = lat_in(:) + lat_inp(jd+1) = 90.0 + deallocate(lat_in) + allocate(lat_in(1:jdp)) + lat_in(:) = lat_inp(:) + else + jdp=jd + endif + call horiz_interp_init() + lon_in = lon_in*PI_180 + lat_in = lat_in*PI_180 + allocate(x_in(id,jdp), y_in(id,jdp)) + call meshgrid(lon_in, lat_in, x_in, y_in) + lon_out(:,:) = G%geoLonT(:,:)*PI_180 + lat_out(:,:) = G%geoLatT(:,:)*PI_180 + allocate(data_in(id,jd,kd)) ; data_in(:,:,:)=0.0 + allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 + allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 + allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 + allocate(last_row(id)) ; last_row(:)=0.0 else - jdp=jd + allocate(data_in(isd:ied,jsd:jed,kd)) endif - ! construct level cell boundaries as the mid-point between adjacent centers - z_edges_in(1) = 0.0 do k=2,kd z_edges_in(k) = 0.5*(z_in(k-1)+z_in(k)) enddo z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1) - call horiz_interp_init() - - lon_in = lon_in*PI_180 - lat_in = lat_in*PI_180 - allocate(x_in(id,jdp), y_in(id,jdp)) - call meshgrid(lon_in, lat_in, x_in, y_in) - - lon_out(:,:) = G%geoLonT(:,:)*PI_180 - lat_out(:,:) = G%geoLatT(:,:)*PI_180 - - allocate(data_in(id,jd,kd)) ; data_in(:,:,:)=0.0 - allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 - allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 - allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 - allocate(last_row(id)) ; last_row(:)=0.0 max_depth = maxval(G%bathyT) call mpp_max(max_depth) @@ -743,8 +748,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (z_edges_in(kd+1) abs(roundoff*missing_value)) then @@ -772,88 +776,88 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole - else + else tr_inp(:,:) = tr_in(:,:) + endif + endif - endif + call mpp_sync() + call mpp_broadcast(tr_inp, id*jdp, root_PE()) + call mpp_sync_self() - call mpp_sync() - call mpp_broadcast(tr_inp, id*jdp, root_PE()) - call mpp_sync_self() + mask_in=0.0 - mask_in=0.0 + do j=1,jdp ; do i=1,id + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j)=1.0 + tr_inp(i,j) = tr_inp(i,j) * conversion + else + tr_inp(i,j) = missing_value + endif + enddo ; enddo - do j=1,jdp ; do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j)=1.0 - tr_inp(i,j) = tr_inp(i,j) * conversion - else - tr_inp(i,j) = missing_value + ! call fms routine horiz_interp to interpolate input level data to model horizontal grid + if (k == 1) then + call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=.true.) endif - enddo ; enddo - ! call fms routine horiz_interp to interpolate input level data to model horizontal grid - if (k == 1) then - call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & - interp_method='bilinear', src_modulo=.true.) - endif + if (debug) then + call myStats(tr_in, missing_value, 1, id, 1, jd, k, 'Tracer from file') + endif - if (debug) then - call myStats(tr_in, missing_value, 1, id, 1, jd, k, 'Tracer from file') - endif + tr_out(:,:) = 0.0 - tr_out(:,:) = 0.0 - - call horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, & + call horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, & new_missing_handle=.true.) - mask_out(:,:) = 1.0 - do j=js,je ; do i=is,ie - if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. - enddo ; enddo + mask_out(:,:) = 1.0 + do j=js,je ; do i=is,ie + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. + enddo ; enddo - fill(:,:) = 0.0 ; good(:,:) = 0.0 + fill(:,:) = 0.0 ; good(:,:) = 0.0 - nPoints = 0 ; varAvg = 0. - do j=js,je ; do i=is,ie - if (mask_out(i,j) < 1.0) then - tr_out(i,j) = missing_value - else - good(i,j) = 1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) + nPoints = 0 ; varAvg = 0. + do j=js,je ; do i=is,ie + if (mask_out(i,j) < 1.0) then + tr_out(i,j) = missing_value + else + good(i,j) = 1.0 + nPoints = nPoints + 1 + varAvg = varAvg + tr_out(i,j) + endif + if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j)) .and. & + (mask_out(i,j) < 1.0)) & + fill(i,j)=1.0 + enddo ; enddo + call pass_var(fill, G%Domain) + call pass_var(good, G%Domain) + + if (debug) then + call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()') endif - if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j)) .and. & - (mask_out(i,j) < 1.0)) & - fill(i,j)=1.0 - enddo ; enddo - call pass_var(fill, G%Domain) - call pass_var(good, G%Domain) - if (debug) then - call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()') - endif + ! Horizontally homogenize data to produce perfectly "flat" initial conditions + if (PRESENT(homogenize)) then ; if (homogenize) then + call sum_across_PEs(nPoints) + call sum_across_PEs(varAvg) + if (nPoints>0) then + varAvg = varAvg/real(nPoints) + endif + tr_out(:,:) = varAvg + endif ; endif - ! Horizontally homogenize data to produce perfectly "flat" initial conditions - if (PRESENT(homogenize)) then ; if (homogenize) then - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg/real(nPoints) - endif - tr_out(:,:) = varAvg - endif ; endif + ! tr_out contains input z-space data on the model grid with missing values + ! now fill in missing values using "ICE-nine" algorithm. - ! tr_out contains input z-space data on the model grid with missing values - ! now fill in missing values using "ICE-nine" algorithm. + tr_outf(:,:) = tr_out(:,:) + if (k==1) tr_prev(:,:) = tr_outf(:,:) + good2(:,:) = good(:,:) + fill2(:,:) = fill(:,:) - tr_outf(:,:) = tr_out(:,:) - if (k==1) tr_prev(:,:) = tr_outf(:,:) - good2(:,:) = good(:,:) - fill2(:,:) = fill(:,:) - - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true.) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true.) ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) @@ -861,16 +865,25 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t ! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') - tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) - mask_z(:,:,k) = good2(:,:) + fill2(:,:) - tr_prev(:,:) = tr_z(:,:,k) - - if (debug) then - call hchksum(tr_prev,'field after fill ',G%HI) - endif + tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) + mask_z(:,:,k) = good2(:,:) + fill2(:,:) + tr_prev(:,:) = tr_z(:,:,k) - enddo ! kd + if (debug) then + call hchksum(tr_prev,'field after fill ',G%HI) + endif + enddo ! kd + else + do k=1,kd + do j=js,je + do i=is,ie + tr_z(i,j,k)=data_in(i,j,k) + if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. + enddo + enddo + enddo + endif end subroutine horiz_interp_and_extrap_tracer_fms_id diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 063c970f94..1f5401ee58 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1732,7 +1732,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C 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 - pres(:) = 0.0 ; eta(:,:,:) = 0.0 ; tmp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 + pres(:) = 0.0 ; tmp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) @@ -1789,7 +1789,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C ! 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)) + allocate(eta(isd:ied,jsd:jed,nz+1)); eta(:,:,:) = 0.0 call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) do j=js,je ; do i=is,ie diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 0cc63a8fc0..05b659f7d3 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -130,6 +130,7 @@ module MOM_ALE_sponge type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays logical :: new_sponges !< True if using newer sponge code + logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid end type ALE_sponge_CS contains @@ -390,6 +391,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries + logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme if (associated(CS)) then @@ -425,6 +427,11 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & + "When defined, the incoming sponge data are "//& + "assumed to be on the model grid " , & + default=.false.) + CS%new_sponges = .true. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec @@ -636,7 +643,12 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p ! containing time-interpolated values from an external file corresponding ! to the current model date. - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) + if (CS%spongeDataOngrid) then + CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname,domain=G%Domain%mpp_domain) + else + CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) + endif + fld_sz(1:4)=-1 fld_sz = get_external_field_size(CS%Ref_val(CS%fldno)%id) nz_data = fld_sz(3) @@ -891,7 +903,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) mask_z(:,:,:)=0.0 call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z) + missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z,spongeOnGrid=CS%SpongeDataOngrid) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) From 3401eb10c7d59e56cfbc6e6122c6e3bf0343aedf Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 13 Sep 2019 17:04:13 -0400 Subject: [PATCH 060/259] shortened line length. Thanks Travis. --- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 05b659f7d3..da62ab11db 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -903,7 +903,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) mask_z(:,:,:)=0.0 call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z,spongeOnGrid=CS%SpongeDataOngrid) + missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z,spongeOnGrid=CS%SpongeDataOngrid) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) From 2efbf532ecac1fd419031e847915593116654fc0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 16 Sep 2019 17:50:02 +0000 Subject: [PATCH 061/259] Cleaned up indentation --- src/framework/MOM_horizontal_regridding.F90 | 95 +++---- .../vertical/MOM_ALE_sponge.F90 | 249 +++++++++--------- 2 files changed, 164 insertions(+), 180 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 8d3b7082b1..6e72242e70 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -89,14 +89,13 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) call min_across_PEs(minA) call max_across_PEs(maxA) if (is_root_pe()) then - write(lMesg(1:120),'(2(a,es12.4),a,i3,x,a)') & - 'init_from_Z: min=',minA,' max=',maxA,' Level=',k,trim(mesg) - call MOM_mesg(lMesg,2) + write(lMesg(1:120),'(2(a,es12.4),a,i3,x,a)') & + 'init_from_Z: min=',minA,' max=',maxA,' Level=',k,trim(mesg) + call MOM_mesg(lMesg,2) endif end subroutine myStats - !> Use ICE-9 algorithm to populate points (fill=1) with !! valid data (good=1). If no information is available, !! Then use a previous guess (prev). Optionally (smooth) @@ -124,7 +123,6 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, !! to the "sienna" code release. logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. - real, dimension(SZI_(G),SZJ_(G)) :: b,r real, dimension(SZI_(G),SZJ_(G)) :: fill_pts, good_, good_new @@ -339,7 +337,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call cpu_clock_begin(id_clock_read) - rcode = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (rcode /= 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& " in hinterp_extrap") @@ -371,7 +368,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& " in file "//trim(filename)//" in hinterp_extrap") - missing_value=0.0 rcode = NF90_GET_ATT(ncid, varid, "_FillValue", missing_value) if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//& @@ -383,7 +379,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, rcode = NF90_GET_ATT(ncid, varid, "scale_factor", scale_factor) if (rcode /= 0) scale_factor = 1.0 - if (allocated(lon_in)) deallocate(lon_in) if (allocated(lat_in)) deallocate(lat_in) if (allocated(z_in)) deallocate(z_in) @@ -391,7 +386,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (allocated(tr_z)) deallocate(tr_z) if (allocated(mask_z)) deallocate(mask_z) - allocate(lon_in(id),lat_in(jd),z_in(kd),z_edges_in(kd+1)) allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) @@ -412,7 +406,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif -! extrapolate the input data to the north pole using the northerm-most latitude + ! extrapolate the input data to the north pole using the northerm-most latitude max_lat = maxval(lat_in) add_np=.false. @@ -429,7 +423,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, jdp=jd endif -! construct level cell boundaries as the mid-point between adjacent centers + ! construct level cell boundaries as the mid-point between adjacent centers z_edges_in(1) = 0.0 do K=2,kd @@ -458,14 +452,11 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (z_edges_in(kd+1) abs(roundoff*missing_value)) then - pole = pole+last_row(i) - npole = npole+1.0 - endif + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + pole = pole+last_row(i) + npole = npole+1.0 + endif enddo if (npole > 0) then - pole=pole/npole + pole=pole/npole else - pole=missing_value + pole=missing_value endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole else tr_inp(:,:) = tr_in(:,:) endif - endif call mpp_sync() @@ -799,8 +785,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (k == 1) then - call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & - interp_method='bilinear', src_modulo=.true.) + call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=.true.) endif if (debug) then @@ -810,7 +796,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t tr_out(:,:) = 0.0 call horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, & - new_missing_handle=.true.) + new_missing_handle=.true.) mask_out(:,:) = 1.0 do j=js,je ; do i=is,ie @@ -829,8 +815,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t varAvg = varAvg + tr_out(i,j) endif if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j)) .and. & - (mask_out(i,j) < 1.0)) & - fill(i,j)=1.0 + (mask_out(i,j) < 1.0)) & + fill(i,j)=1.0 enddo ; enddo call pass_var(fill, G%Domain) call pass_var(good, G%Domain) @@ -849,9 +835,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t tr_out(:,:) = varAvg endif ; endif - ! tr_out contains input z-space data on the model grid with missing values - ! now fill in missing values using "ICE-nine" algorithm. - + ! tr_out contains input z-space data on the model grid with missing values + ! now fill in missing values using "ICE-nine" algorithm. tr_outf(:,:) = tr_out(:,:) if (k==1) tr_prev(:,:) = tr_outf(:,:) good2(:,:) = good(:,:) @@ -859,11 +844,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true.) -! if (debug) then -! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) -! endif +! if (debug) then +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) +! endif -! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') +! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) mask_z(:,:,k) = good2(:,:) + fill2(:,:) @@ -884,9 +869,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo enddo endif -end subroutine horiz_interp_and_extrap_tracer_fms_id - +end subroutine horiz_interp_and_extrap_tracer_fms_id !> Create a 2d-mesh of grid coordinates from 1-d arrays. subroutine meshgrid(x, y, x_T, y_T) @@ -1009,7 +993,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) Isum = 1.0/bsum res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& - B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) + B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) endif enddo enddo @@ -1027,5 +1011,4 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) end subroutine smooth_heights - end module MOM_horizontal_regridding diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index da62ab11db..dc1a9156da 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -472,70 +472,70 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if (CS%sponge_uv) then - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 - allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 - - ! u points - CS%num_col_u = 0 ; !CS%fldno_u = 0 - do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB - Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & - CS%num_col_u = CS%num_col_u + 1 - enddo ; enddo - - if (CS%num_col_u > 0) then - - allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 - allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 - allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 - - ! pass indices, restoring time to the CS structure - col = 1 - do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then - CS%col_i_u(col) = i ; CS%col_j_u(col) = j - CS%Iresttime_col_u(col) = Iresttime_u(i,j) - col = col +1 - endif - enddo ; enddo - - ! same for total number of arbritary layers and correspondent data - - endif - total_sponge_cols_u = CS%num_col_u - call sum_across_PEs(total_sponge_cols_u) - call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") - - ! v points - CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec - Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & - CS%num_col_v = CS%num_col_v + 1 - enddo ; enddo - - if (CS%num_col_v > 0) then - - allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 - allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 - allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 - - ! pass indices, restoring time to the CS structure - col = 1 - do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then - CS%col_i_v(col) = i ; CS%col_j_v(col) = j - CS%Iresttime_col_v(col) = Iresttime_v(i,j) - col = col +1 - endif - enddo ; enddo - - endif - total_sponge_cols_v = CS%num_col_v - call sum_across_PEs(total_sponge_cols_v) - call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 + + ! u points + CS%num_col_u = 0 ; !CS%fldno_u = 0 + do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB + Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + CS%num_col_u = CS%num_col_u + 1 + enddo ; enddo + + if (CS%num_col_u > 0) then + + allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 + allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 + allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 + + ! pass indices, restoring time to the CS structure + col = 1 + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + CS%col_i_u(col) = i ; CS%col_j_u(col) = j + CS%Iresttime_col_u(col) = Iresttime_u(i,j) + col = col +1 + endif + enddo ; enddo + + ! same for total number of arbritary layers and correspondent data + + endif + total_sponge_cols_u = CS%num_col_u + call sum_across_PEs(total_sponge_cols_u) + call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & + "The total number of columns where sponges are applied at u points.") + + ! v points + CS%num_col_v = 0 ; !CS%fldno_v = 0 + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + CS%num_col_v = CS%num_col_v + 1 + enddo ; enddo + + if (CS%num_col_v > 0) then + + allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 + allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 + allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 + + ! pass indices, restoring time to the CS structure + col = 1 + do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + CS%col_i_v(col) = i ; CS%col_j_v(col) = j + CS%Iresttime_col_v(col) = Iresttime_v(i,j) + col = col +1 + endif + enddo ; enddo + + endif + total_sponge_cols_v = CS%num_col_v + call sum_across_PEs(total_sponge_cols_v) + call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & + "The total number of columns where sponges are applied at v points.") endif end subroutine initialize_ALE_sponge_varying @@ -561,7 +561,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure (in/out). real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & - intent(in) :: sp_val !< Field to be used in the sponge, it has arbritary number of layers. + intent(in) :: sp_val !< Field to be used in the sponge, it has arbitrary number of layers. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & target, intent(in) :: f_ptr !< Pointer to the field to be damped @@ -632,7 +632,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed CS%fldno = CS%fldno + 1 - if (CS%fldno > MAX_FIELDS_) then + if (CS%fldno > MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & &initialize_sponge." )') CS%fldno @@ -644,9 +644,9 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p ! to the current model date. if (CS%spongeDataOngrid) then - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname,domain=G%Domain%mpp_domain) + CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname,domain=G%Domain%mpp_domain) else - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) + CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) endif fld_sz(1:4)=-1 @@ -669,16 +669,16 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - ! call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - ! missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) +! call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & +! missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) -! Do not think halo updates are needed (mjh) -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) + ! Do not think halo updates are needed (mjh) +! call pass_var(sp_val,G%Domain) +! call pass_var(mask_z,G%Domain) -! Done with horizontal interpolation. -! Now remap to model coordinates -! First we reserve a work space for reconstructions of the source data + ! Done with horizontal interpolation. + ! Now remap to model coordinates + ! First we reserve a work space for reconstructions of the source data allocate( hsrc(nz_data) ) allocate( tmpT1d(nz_data) ) @@ -704,7 +704,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p CS%Ref_val(CS%fldno)%h(1:nz_data,col) = 0. CS%Ref_val(CS%fldno)%p(1:nz_data,col) = -1.e24 CS%Ref_val(CS%fldno)%h(1:nz_data,col) = GV%Z_to_H*hsrc(1:nz_data) -! CS%Ref_val(CS%fldno)%p(1:nz_data,col) = tmpT1d(1:nz_data) +! CS%Ref_val(CS%fldno)%p(1:nz_data,col) = tmpT1d(1:nz_data) enddo CS%var(CS%fldno)%p => f_ptr @@ -818,7 +818,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,u_val,mask_u,z_in,z_edges_in,& missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) -!!! TODO: add a velocity interface! (mjh) + !!! TODO: add a velocity interface! (mjh) ! Interpolate external file data to the model grid ! I am hard-wiring this call to assume that the input grid is zonally re-entrant @@ -891,7 +891,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%new_sponges) then if (.not. present(Time)) & - call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") + call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") ! Interpolate new grid in time-space do m=1,CS%fldno @@ -905,8 +905,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z,spongeOnGrid=CS%SpongeDataOngrid) -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) +! call pass_var(sp_val,G%Domain) +! call pass_var(mask_z,G%Domain) do c=1,CS%num_col @@ -939,10 +939,10 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) if (CS%new_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%h(1:nz_data,c), tmp_val2, & - CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) + CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else call remapping_core_h(CS%remap_cs,nz_data, CS%Ref_h%p(1:nz_data,c), tmp_val2, & - CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) + CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) endif !Backward Euler method CS%var(m)%p(i,j,1:CS%nz) = I1pdamp * (CS%var(m)%p(i,j,1:CS%nz) + tmp_val1 * damp) @@ -961,7 +961,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! u points do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB; do k=1,nz - hu(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + hu(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) enddo ; enddo ; enddo if (CS%new_sponges) then @@ -971,16 +971,16 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) nz_data = CS%Ref_val_u%nz_data allocate(sp_val(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) allocate(mask_z(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) -! Interpolate from the external horizontal grid and in time + ! Interpolate from the external horizontal grid and in time call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) + missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) +! call pass_var(sp_val,G%Domain) +! call pass_var(mask_z,G%Domain) do c=1,CS%num_col -! c is an index for the next 3 lines but a multiplier for the rest of the loop -! Therefore we use c as per C code and increment the index where necessary. + ! c is an index for the next 3 lines but a multiplier for the rest of the loop + ! Therefore we use c as per C code and increment the index where necessary. i = CS%col_i(c) ; j = CS%col_j(c) CS%Ref_val_u%p(1:nz_data,c) = sp_val(i,j,1:nz_data) enddo @@ -990,16 +990,16 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) nz_data = CS%Ref_val_v%nz_data allocate(sp_val(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) allocate(mask_z(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) -! Interpolate from the external horizontal grid and in time + ! Interpolate from the external horizontal grid and in time call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) + missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) +! call pass_var(sp_val,G%Domain) +! call pass_var(mask_z,G%Domain) do c=1,CS%num_col -! c is an index for the next 3 lines but a multiplier for the rest of the loop -! Therefore we use c as per C code and increment the index where necessary. + ! c is an index for the next 3 lines but a multiplier for the rest of the loop + ! Therefore we use c as per C code and increment the index where necessary. i = CS%col_i(c) ; j = CS%col_j(c) CS%Ref_val_v%p(1:nz_data,c) = sp_val(i,j,1:nz_data) enddo @@ -1011,41 +1011,41 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) endif do c=1,CS%num_col_u - i = CS%col_i_u(c) ; j = CS%col_j_u(c) - damp = dt*CS%Iresttime_col_u(c) - I1pdamp = 1.0 / (1.0 + damp) - if (CS%new_sponges) nz_data = CS%Ref_val(m)%nz_data - tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) - if (CS%new_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%h(:,c), tmp_val2, & - CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) - else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hu%p(:,c), tmp_val2, & - CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) - endif - !Backward Euler method - CS%var_u%p(i,j,:) = I1pdamp * (CS%var_u%p(i,j,:) + tmp_val1 * damp) + i = CS%col_i_u(c) ; j = CS%col_j_u(c) + damp = dt*CS%Iresttime_col_u(c) + I1pdamp = 1.0 / (1.0 + damp) + if (CS%new_sponges) nz_data = CS%Ref_val(m)%nz_data + tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) + if (CS%new_sponges) then + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%h(:,c), tmp_val2, & + CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) + else + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hu%p(:,c), tmp_val2, & + CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) + endif + !Backward Euler method + CS%var_u%p(i,j,:) = I1pdamp * (CS%var_u%p(i,j,:) + tmp_val1 * damp) enddo ! v points do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec; do k=1,nz - hv(i,J,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + hv(i,J,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) enddo ; enddo ; enddo do c=1,CS%num_col_v - i = CS%col_i_v(c) ; j = CS%col_j_v(c) - damp = dt*CS%Iresttime_col_v(c) - I1pdamp = 1.0 / (1.0 + damp) - tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) - if (CS%new_sponges) then - call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_val_v%h(:,c), tmp_val2, & - CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) - else - call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_hv%p(:,c), tmp_val2, & - CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) - endif - !Backward Euler method - CS%var_v%p(i,j,:) = I1pdamp * (CS%var_v%p(i,j,:) + tmp_val1 * damp) + i = CS%col_i_v(c) ; j = CS%col_j_v(c) + damp = dt*CS%Iresttime_col_v(c) + I1pdamp = 1.0 / (1.0 + damp) + tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) + if (CS%new_sponges) then + call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_val_v%h(:,c), tmp_val2, & + CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) + else + call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_hv%p(:,c), tmp_val2, & + CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) + endif + !Backward Euler method + CS%var_v%p(i,j,:) = I1pdamp * (CS%var_v%p(i,j,:) + tmp_val1 * damp) enddo endif @@ -1083,4 +1083,5 @@ subroutine ALE_sponge_end(CS) deallocate(CS) end subroutine ALE_sponge_end + end module MOM_ALE_sponge From f4a4aaeeb6d66b012693c8cce1be93b057bcf2d0 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 16 Sep 2019 11:04:12 -0800 Subject: [PATCH 062/259] More OBC cleanup. --- src/core/MOM_open_boundary.F90 | 171 +++++++++++++++++---------------- 1 file changed, 88 insertions(+), 83 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index a2897c97b8..a65d7ee580 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1998,8 +1998,6 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & (cff_avg + rx_avg) - ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues - ! implemented as a work-around to limitations in restart capability if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability @@ -2217,7 +2215,6 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) elseif (segment%oblique) 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 - if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then dhdx = segment%grad_normal(I-1,1,k) elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then @@ -2269,33 +2266,33 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u > 0.0) then - rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) enddo else do I=segment%HI%IsdB,segment%HI%IedB dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I-1 - rx_tangential(I,J,k) = 0.0 - if (dhdt*dhdy > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + ry_tangential(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) / (1.0+rx_avg) + ry_avg = ry_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (ry_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -2309,19 +2306,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc - rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) ! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then -! rx_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * US%s_to_T*dt * G%IdyBu(I,J-1)) +! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * US%s_to_T*dt * G%IdyBu(I,J-1)) ! elseif (G%mask2dCv(i,J-1) > 0.0) then -! rx_avg = v_new(i,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) +! ry_avg = v_new(i,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) ! elseif (G%mask2dCv(i+1,J-1) > 0.0) then -! rx_avg = v_new(i+1,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) +! ry_avg = v_new(i+1,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) ! else -! rx_avg = 0.0 +! ry_avg = 0.0 ! endif - segment%tangential_grad(I,J,k) = & - ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & - rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+rx_avg) + segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & + ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_grad) then @@ -2337,7 +2333,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) + deallocate(ry_tangential) endif if (segment%oblique_tan .or. segment%oblique_grad) then J=segment%HI%JsdB @@ -2346,32 +2342,32 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u > 0.0) then - rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) enddo else do I=segment%HI%IsdB,segment%HI%IedB dhdt = u_old(I,j,k)-u_new(I,j,k) !old-new - dhdx = u_new(I,j,k)-u_new(I,j-1,k) !in new time backward sasha for I-1 + dhdy = u_new(I,j,k)-u_new(I,j-1,k) !in new time backward sasha for I-1 if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then - dhdy = segment%grad_tan(i,1,k) + dhdx = segment%grad_tan(i,1,k) elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then - dhdy = 0.0 + dhdx = 0.0 else - dhdy = segment%grad_tan(i+1,1,k) + dhdx = segment%grad_tan(i+1,1,k) endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx + if (dhdt*dhdy < 0.0) dhdt = 0.0 + ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) rx_tangential(I,j,k) = rx_new ry_tangential(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new @@ -2383,10 +2379,10 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_avg = rx_tangential(I,J,k) ry_avg = ry_tangential(I,J,k) cff_avg = cff_tangential(I,J,k) - segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) - & - (max(ry_avg,0.0)*segment%grad_tan(i,2,k) + & - min(ry_avg,0.0)*segment%grad_tan(i+1,2,k))) / & - (cff_avg + rx_avg) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) - & + (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & + min(rx_avg,0.0)*segment%grad_tan(i+1,2,k))) / & + (cff_avg + ry_avg) enddo ; enddo endif if (segment%nudged_tan) then @@ -2411,10 +2407,10 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & - rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) - & - (max(ry_avg,0.0)*segment%grad_gradient(I,2,k) + & - min(ry_avg,0.0)*segment%grad_gradient(I+1,2,k))) / & - (cff_avg + rx_avg) + ry_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) - & + (max(rx_avg,0.0)*segment%grad_gradient(I,2,k) + & + min(rx_avg,0.0)*segment%grad_gradient(I+1,2,k))) / & + (cff_avg + ry_avg) enddo ; enddo endif if (segment%nudged_grad) then @@ -2471,6 +2467,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_normal(I,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 + ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) @@ -2487,9 +2484,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) segment%ry_normal(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & - (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & - min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & - (cff_avg + ry_avg) + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) if (gamma_u > 0.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability @@ -2514,24 +2511,33 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) - do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) - enddo + if (gamma_u > 0.0) then + ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + enddo + else + do I=segment%HI%IsdB,segment%HI%IedB + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 + ry_tangential(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + enddo + endif enddo if (segment%radiation_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) / (1.0+rx_avg) + ry_avg = ry_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (ry_tangential(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out @@ -2545,18 +2551,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc - rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) ! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then -! rx_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * US%s_to_T*dt * G%IdyBu(I,J+1) ! elseif (G%mask2dCv(i,J+1) > 0.0) then -! rx_avg = v_new(i,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = v_new(i,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) ! elseif (G%mask2dCv(i+1,J+1) > 0.0) then -! rx_avg = v_new(i+1,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = v_new(i+1,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) ! else -! rx_avg = 0.0 +! ry_avg = 0.0 ! endif segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & - rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+rx_avg) + ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_grad) then @@ -2572,7 +2578,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) + deallocate(ry_tangential) endif if (segment%oblique_tan .or. segment%oblique_grad) then J=segment%HI%JsdB @@ -2581,32 +2587,32 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u > 0.0) then - rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) enddo else do I=segment%HI%IsdB,segment%HI%IedB dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new - dhdx = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 if (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) > 0.0) then - dhdy = segment%grad_tan(i,1,k) + dhdx = segment%grad_tan(i,1,k) elseif (dhdt*(segment%grad_tan(i,1,k) + segment%grad_tan(i+1,1,k)) == 0.0) then - dhdy = 0.0 + dhdx = 0.0 else - dhdy = segment%grad_tan(i+1,1,k) + dhdx = segment%grad_tan(i+1,1,k) endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx + if (dhdt*dhdy < 0.0) dhdt = 0.0 + ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) rx_tangential(I,j,k) = rx_new ry_tangential(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new @@ -2618,11 +2624,10 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_avg = rx_tangential(I,J,k) ry_avg = ry_tangential(I,J,k) cff_avg = cff_tangential(I,J,k) - segment%tangential_vel(I,J,k) = & - ((cff_avg*u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) - & - (max(ry_avg,0.0)*segment%grad_tan(i,2,k) + & - min(ry_avg,0.0)*segment%grad_tan(i+1,2,k)) ) / & - (cff_avg + rx_avg) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) - & + (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & + min(rx_avg,0.0)*segment%grad_tan(i+1,2,k)) ) / & + (cff_avg + ry_avg) enddo ; enddo endif if (segment%nudged_tan) then @@ -2647,10 +2652,10 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & - rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) - & - (max(ry_avg,0.0)*segment%grad_gradient(i,2,k) + & - min(ry_avg,0.0)*segment%grad_gradient(i+1,2,k))) / & - (cff_avg + rx_avg) + ry_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) - & + (max(rx_avg,0.0)*segment%grad_gradient(i,2,k) + & + min(rx_avg,0.0)*segment%grad_gradient(i+1,2,k))) / & + (cff_avg + ry_avg) enddo ; enddo endif if (segment%nudged_grad) then From 51fda4d7d9b1a2288163a7341ee9069875157424 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 16 Sep 2019 11:35:49 -0800 Subject: [PATCH 063/259] Deleted unwanted commented OBC code. --- src/core/MOM_open_boundary.F90 | 27 --------------------------- 1 file changed, 27 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index a65d7ee580..680a25cae0 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2939,33 +2939,6 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) enddo endif -! do n=1,OBC%number_of_segments -! segment => OBC%segment(n) -! if (.not. segment%on_pe) cycle - -! if (segment%direction == OBC_DIRECTION_E) then -! I=segment%HI%IsdB -! do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed -! h(i+1,j,k) = h(i,j,k) -! enddo ; enddo -! elseif (segment%direction == OBC_DIRECTION_W) then -! I=segment%HI%IsdB -! do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed -! h(i,j,k) = h(i+1,j,k) -! enddo ; enddo -! elseif (segment%direction == OBC_DIRECTION_N) then -! J=segment%HI%JsdB -! do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied -! h(i,j+1,k) = h(i,j,k) -! enddo ; enddo -! elseif (segment%direction == OBC_DIRECTION_S) then -! J=segment%HI%JsdB -! do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied -! h(i,j,k) = h(i,j+1,k) -! enddo ; enddo -! endif -! enddo - end subroutine set_tracer_data !> Needs documentation From 70c09a1d92890827f621a8153883a1dee4a3c1c0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 17 Sep 2019 13:00:22 +0000 Subject: [PATCH 064/259] White space --- src/framework/MOM_horizontal_regridding.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 6e72242e70..b39ed7f531 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -736,7 +736,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (is_root_pe()) & call time_interp_external(fms_id, Time, data_in, verbose=.true.) - + ! roundoff = 3.0*EPSILON(missing_value) roundoff = 1.e-4 From 725e17d6bcece99d744bac56ce02d751b50795ae Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 17 Sep 2019 09:26:22 -0400 Subject: [PATCH 065/259] Communication bugfix and fix sponge index --- src/framework/MOM_horizontal_regridding.F90 | 15 +++++++++------ src/parameterizations/vertical/MOM_ALE_sponge.F90 | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 6e72242e70..094005bf7c 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -734,16 +734,18 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (z_edges_in(kd+1) Date: Tue, 17 Sep 2019 10:02:57 -0400 Subject: [PATCH 066/259] Added sponge test in hidden directory --- .testing/_tc4/MOM_input | 399 ++++++++++++++++++++++++++++++++++++ .testing/_tc4/build_data.py | 68 ++++++ .testing/_tc4/build_grid.py | 66 ++++++ .testing/_tc4/diag_table | 49 +++++ .testing/_tc4/input.nml | 27 +++ .testing/_tc4/prep.bash | 5 + 6 files changed, 614 insertions(+) create mode 100644 .testing/_tc4/MOM_input create mode 100644 .testing/_tc4/build_data.py create mode 100644 .testing/_tc4/build_grid.py create mode 100644 .testing/_tc4/diag_table create mode 100644 .testing/_tc4/input.nml create mode 100644 .testing/_tc4/prep.bash diff --git a/.testing/_tc4/MOM_input b/.testing/_tc4/MOM_input new file mode 100644 index 0000000000..93feb3f32c --- /dev/null +++ b/.testing/_tc4/MOM_input @@ -0,0 +1,399 @@ +! This file was written by the model and records the non-default parameters used at run-time. + +! === module MOM === + +! === module MOM_unit_scaling === +! Parameters for doing unit scaling of variables. +USE_REGRIDDING = True ! [Boolean] default = False + ! If True, use the ALE algorithm (regridding/remapping). If False, use the + ! layered isopycnal algorithm. +DT = 300.0 ! [s] + ! The (baroclinic) dynamics time step. The time-step that is actually used will + ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode + ! or the coupling timestep in coupled mode.) +C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 + ! The heat capacity of sea water, approximated as a constant. This is only used + ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 + ! definition of conservative temperature. +SAVE_INITIAL_CONDS = True ! [Boolean] default = False + ! If true, write the initial conditions to a file given by IC_OUTPUT_FILE. + +! === module MOM_domains === +REENTRANT_X = False ! [Boolean] default = True + ! If true, the domain is zonally reentrant. +NIGLOBAL = 10 ! + ! The total number of thickness grid points in the x-direction in the physical + ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. +NJGLOBAL = 10 ! + ! The total number of thickness grid points in the y-direction in the physical + ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. + +! === module MOM_hor_index === +! Sets the horizontal array index types. + +! === module MOM_verticalGrid === +! Parameters providing information about the vertical grid. +NK = 2 ! [nondim] + ! The number of model layers. + +! === module MOM_fixed_initialization === + +! === module MOM_grid_init === +GRID_CONFIG = "mosaic" ! + ! A character string that determines the method for defining the horizontal + ! grid. Current options are: + ! mosaic - read the grid from a mosaic (supergrid) + ! file set by GRID_FILE. + ! cartesian - use a (flat) Cartesian grid. + ! spherical - use a simple spherical grid. + ! mercator - use a Mercator spherical grid. +GRID_FILE = "ocean_hgrid.nc" ! + ! Name of the file from which to read horizontal grid data. +TOPO_CONFIG = "file" ! + ! This specifies how bathymetry is specified: + ! file - read bathymetric information from the file + ! specified by (TOPO_FILE). + ! flat - flat bottom set to MAXIMUM_DEPTH. + ! bowl - an analytically specified bowl-shaped basin + ! ranging between MAXIMUM_DEPTH and MINIMUM_DEPTH. + ! spoon - a similar shape to 'bowl', but with an vertical + ! wall at the southern face. + ! halfpipe - a zonally uniform channel with a half-sine + ! profile in the meridional direction. + ! benchmark - use the benchmark test case topography. + ! Neverland - use the Neverland test case topography. + ! DOME - use a slope and channel configuration for the + ! DOME sill-overflow test case. + ! ISOMIP - use a slope and channel configuration for the + ! ISOMIP test case. + ! DOME2D - use a shelf and slope configuration for the + ! DOME2D gravity current/overflow test case. + ! Kelvin - flat but with rotated land mask. + ! seamount - Gaussian bump for spontaneous motion test case. + ! dumbbell - Sloshing channel with reservoirs on both ends. + ! shelfwave - exponential slope for shelfwave test case. + ! Phillips - ACC-like idealized topography used in the Phillips config. + ! dense - Denmark Strait-like dense water formation and overflow. + ! USER - call a user modified routine. +!MAXIMUM_DEPTH = 100.0 ! [m] + ! The (diagnosed) maximum depth of the ocean. + +! === module MOM_open_boundary === +! Controls where open boundaries are located, what kind of boundary condition to impose, and what data to apply, +! if any. +ROTATION = "betaplane" ! default = "2omegasinlat" + ! This specifies how the Coriolis parameter is specified: + ! 2omegasinlat - Use twice the planetary rotation rate + ! times the sine of latitude. + ! betaplane - Use a beta-plane or f-plane. + ! USER - call a user modified routine. +F_0 = 1.0E-04 ! [s-1] default = 0.0 + ! The reference value of the Coriolis parameter with the betaplane option. + +! === module MOM_tracer_registry === + +! === module MOM_EOS === +EQN_OF_STATE = "LINEAR" ! default = "WRIGHT" + ! EQN_OF_STATE determines which ocean equation of state should be used. + ! Currently, the valid choices are "LINEAR", "UNESCO", "WRIGHT", "NEMO" and + ! "TEOS10". This is only used if USE_EOS is true. +DRHO_DS = 0.0 ! [kg m-3 PSU-1] default = 0.8 + ! When EQN_OF_STATE=LINEAR, this is the partial derivative of density with + ! salinity. + +! === module MOM_restart === + +! === module MOM_tracer_flow_control === + +! === module MOM_coord_initialization === +COORD_CONFIG = "linear" ! + ! This specifies how layers are to be defined: + ! ALE or none - used to avoid defining layers in ALE mode + ! file - read coordinate information from the file + ! specified by (COORD_FILE). + ! BFB - Custom coords for buoyancy-forced basin case + ! based on SST_S, T_BOT and DRHO_DT. + ! linear - linear based on interfaces not layers + ! layer_ref - linear based on layer densities + ! ts_ref - use reference temperature and salinity + ! ts_range - use range of temperature and salinity + ! (T_REF and S_REF) to determine surface density + ! and GINT calculate internal densities. + ! gprime - use reference density (RHO_0) for surface + ! density and GINT calculate internal densities. + ! ts_profile - use temperature and salinity profiles + ! (read from COORD_FILE) to set layer densities. + ! USER - call a user modified routine. +REGRIDDING_COORDINATE_MODE = "Z*" ! default = "LAYER" + ! Coordinate mode for vertical regridding. Choose among the following + ! possibilities: LAYER - Isopycnal or stacked shallow water layers + ! ZSTAR, Z* - stretched geopotential z* + ! SIGMA_SHELF_ZSTAR - stretched geopotential z* ignoring shelf + ! SIGMA - terrain following coordinates + ! RHO - continuous isopycnal + ! HYCOM1 - HyCOM-like hybrid coordinate + ! SLIGHT - stretched coordinates above continuous isopycnal + ! ADAPTIVE - optimize for smooth neutral density surfaces +!ALE_RESOLUTION = 2*50.0 ! [m] + ! The distribution of vertical resolution for the target + ! grid used for Eulerian-like coordinates. For example, + ! in z-coordinate mode, the parameter is a list of level + ! thicknesses (in m). In sigma-coordinate mode, the list + ! is of non-dimensional fractions of the water column. +REMAPPING_SCHEME = "PPM_IH4" ! default = "PLM" + ! This sets the reconstruction scheme used for vertical remapping for all + ! variables. It can be one of the following schemes: PCM (1st-order + ! accurate) + ! PLM (2nd-order accurate) + ! PPM_H4 (3rd-order accurate) + ! PPM_IH4 (3rd-order accurate) + ! PQM_IH4IH3 (4th-order accurate) + ! PQM_IH6IH5 (5th-order accurate) + +! === module MOM_grid === +! Parameters providing information about the lateral grid. + +! === module MOM_state_initialization === +INIT_LAYERS_FROM_Z_FILE = True ! [Boolean] default = False + ! If true, initialize the layer thicknesses, temperatures, and salinities from a + ! Z-space file on a latitude-longitude grid. + +! === module MOM_initialize_layers_from_Z === +TEMP_SALT_Z_INIT_FILE = "temp_salt_ic.nc" ! default = "temp_salt_z.nc" + ! The name of the z-space input file used to initialize temperatures (T) and + ! salinities (S). If T and S are not in the same file, TEMP_Z_INIT_FILE and + ! SALT_Z_INIT_FILE must be set. +Z_INIT_ALE_REMAPPING = True ! [Boolean] default = False + ! If True, then remap straight to model coordinate from file. +SPONGE = True ! [Boolean] default = False + ! If true, sponges may be applied anywhere in the domain. The exact location and + ! properties of those sponges are specified via SPONGE_CONFIG. +SPONGE_DAMPING_FILE = "sponge.nc" ! + ! The name of the file with the sponge damping rates. +SPONGE_STATE_FILE = "temp_salt_ic.nc" ! default = "sponge.nc" + ! The name of the file with the state to damp toward. +SPONGE_PTEMP_VAR = "ptemp" ! default = "PTEMP" + ! The name of the potential temperature variable in SPONGE_STATE_FILE. +SPONGE_SALT_VAR = "salt" ! default = "SALT" + ! The name of the salinity variable in SPONGE_STATE_FILE. +NEW_SPONGES = True ! [of sponge restoring data.] default = False + ! Set True if using the newer sponging code which performs on-the-fly regridding + ! in lat-lon-time. + +! === module MOM_sponge === +SPONGE_DATA_ONGRID = True ! [Boolean] default = False + ! When defined, the incoming sponge data are assumed to be on the model grid +!Total sponge columns at h points = 100 ! + ! The total number of columns where sponges are applied at h points. + +! === module MOM_diag_mediator === + +! === module MOM_MEKE === + +! === module MOM_lateral_mixing_coeffs === + +! === module MOM_set_visc === +LINEAR_DRAG = True ! [Boolean] default = False + ! If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag law is + ! cdrag*DRAG_BG_VEL*u. +HBBL = 10.0 ! [m] + ! The thickness of a bottom boundary layer with a viscosity of KVBBL if + ! BOTTOMDRAGLAW is not defined, or the thickness over which near-bottom + ! velocities are averaged for the drag law if BOTTOMDRAGLAW is defined but + ! LINEAR_DRAG is not. +CDRAG = 0.002 ! [nondim] default = 0.003 + ! CDRAG is the drag coefficient relating the magnitude of the velocity field to + ! the bottom stress. CDRAG is only used if BOTTOMDRAGLAW is defined. +DRAG_BG_VEL = 0.05 ! [m s-1] default = 0.0 + ! DRAG_BG_VEL is either the assumed bottom velocity (with LINEAR_DRAG) or an + ! unresolved velocity that is combined with the resolved velocity to estimate + ! the velocity magnitude. DRAG_BG_VEL is only used when BOTTOMDRAGLAW is + ! defined. +BBL_USE_EOS = True ! [Boolean] default = False + ! If true, use the equation of state in determining the properties of the bottom + ! boundary layer. Otherwise use the layer target potential densities. +BBL_THICK_MIN = 0.1 ! [m] default = 0.0 + ! The minimum bottom boundary layer thickness that can be used with + ! BOTTOMDRAGLAW. This might be Kv/(cdrag*drag_bg_vel) to give Kv as the minimum + ! near-bottom viscosity. +KV = 1.0E-04 ! [m2 s-1] + ! The background kinematic viscosity in the interior. The molecular value, ~1e-6 + ! m2 s-1, may be used. + +! === module MOM_thickness_diffuse === +KHTH = 500.0 ! [m2 s-1] default = 0.0 + ! The background horizontal thickness diffusivity. +BE = 0.7 ! [nondim] default = 0.6 + ! If SPLIT is true, BE determines the relative weighting of a 2nd-order + ! Runga-Kutta baroclinic time stepping scheme (0.5) and a backward Euler scheme + ! (1) that is used for the Coriolis and inertial terms. BE may be from 0.5 to + ! 1, but instability may occur near 0.5. BE is also applicable if SPLIT is false + ! and USE_RK2 is true. + +! === module MOM_continuity === + +! === module MOM_continuity_PPM === +ETA_TOLERANCE = 1.0E-12 ! [m] default = 1.0E-10 + ! The tolerance for the differences between the barotropic and baroclinic + ! estimates of the sea surface height due to the fluxes through each face. The + ! total tolerance for SSH is 4 times this value. The default is + ! 0.5*NK*ANGSTROM, and this should not be set less than about + ! 10^-15*MAXIMUM_DEPTH. + +! === module MOM_CoriolisAdv === +CORIOLIS_EN_DIS = True ! [Boolean] default = False + ! If true, two estimates of the thickness fluxes are used to estimate the + ! Coriolis term, and the one that dissipates energy relative to the other one is + ! used. +BOUND_CORIOLIS = True ! [Boolean] default = False + ! If true, the Coriolis terms at u-points are bounded by the four estimates of + ! (f+rv)v from the four neighboring v-points, and similarly at v-points. This + ! option is always effectively false with CORIOLIS_EN_DIS defined and + ! CORIOLIS_SCHEME set to SADOURNY75_ENERGY. + +! === module MOM_PressureForce === + +! === module MOM_PressureForce_AFV === +RECONSTRUCT_FOR_PRESSURE = False ! [Boolean] default = True + ! If True, use vertical reconstruction of T & S within the integrals of the FV + ! pressure gradient calculation. If False, use the constant-by-layer algorithm. + ! The default is set by USE_REGRIDDING. + +! === module MOM_hor_visc === +SMAGORINSKY_AH = True ! [Boolean] default = False + ! If true, use a biharmonic Smagorinsky nonlinear eddy viscosity. +SMAG_BI_CONST = 0.03 ! [nondim] default = 0.0 + ! The nondimensional biharmonic Smagorinsky constant, typically 0.015 - 0.06. + +! === module MOM_vert_friction === +DIRECT_STRESS = True ! [Boolean] default = False + ! If true, the wind stress is distributed over the topmost HMIX_STRESS of fluid + ! (like in HYCOM), and KVML may be set to a very small value. +HMIX_FIXED = 20.0 ! [m] + ! The prescribed depth over which the near-surface viscosity and diffusivity are + ! elevated when the bulk mixed layer is not used. +KVML = 0.01 ! [m2 s-1] default = 1.0E-04 + ! The kinematic viscosity in the mixed layer. A typical value is ~1e-2 m2 s-1. + ! KVML is not used if BULKMIXEDLAYER is true. The default is set by KV. +MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 + ! The maximum velocity allowed before the velocity components are truncated. + +! === module MOM_barotropic === +BOUND_BT_CORRECTION = True ! [Boolean] default = False + ! If true, the corrective pseudo mass-fluxes into the barotropic solver are + ! limited to values that require less than maxCFL_BT_cont to be accommodated. +SSH_EXTRA = 10.0 ! [m] default = 5.0 + ! An estimate of how much higher SSH might get, for use in calculating the safe + ! external wave speed. The default is the minimum of 10 m or 5% of + ! MAXIMUM_DEPTH. +BEBT = 0.2 ! [nondim] default = 0.1 + ! BEBT determines whether the barotropic time stepping uses the forward-backward + ! time-stepping scheme or a backward Euler scheme. BEBT is valid in the range + ! from 0 (for a forward-backward treatment of nonrotating gravity waves) to 1 + ! (for a backward Euler treatment). In practice, BEBT must be greater than about + ! 0.05. +DTBT = 10.0 ! [s or nondim] default = -0.98 + ! The barotropic time step, in s. DTBT is only used with the split explicit time + ! stepping. To set the time step automatically based the maximum stable value + ! use 0, or a negative value gives the fraction of the stable value. Setting + ! DTBT to 0 is the same as setting it to -0.98. The value of DTBT that will + ! actually be used is an integer fraction of DT, rounding down. + +! === module MOM_mixed_layer_restrat === + +! === module MOM_diabatic_driver === +! The following parameters are used for diabatic processes. + +! === module MOM_CVMix_KPP === +! This is the MOM wrapper to CVMix:KPP +! See http://cvmix.github.io/ + +! === module MOM_tidal_mixing === +! Vertical Tidal Mixing Parameterization + +! === module MOM_CVMix_conv === +! Parameterization of enhanced mixing due to convection via CVMix + +! === module MOM_entrain_diffusive === +CORRECT_DENSITY = False ! [Boolean] default = True + ! If true, and USE_EOS is true, the layer densities are restored toward their + ! target values by the diapycnal mixing, as described in Hallberg (MWR, 2000). + +! === module MOM_set_diffusivity === +BBL_EFFIC = 0.0 ! [nondim] default = 0.2 + ! The efficiency with which the energy extracted by bottom drag drives BBL + ! diffusion. This is only used if BOTTOMDRAGLAW is true. + +! === module MOM_bkgnd_mixing === +! Adding static vertical background mixing coefficients +KD = 0.0 ! [m2 s-1] + ! The background diapycnal diffusivity of density in the interior. Zero or the + ! molecular value, ~1e-7 m2 s-1, may be used. + +! === module MOM_kappa_shear === +! Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008 + +! === module MOM_CVMix_shear === +! Parameterization of shear-driven turbulence via CVMix (various options) + +! === module MOM_CVMix_ddiff === +! Parameterization of mixing due to double diffusion processes via CVMix + +! === module MOM_diabatic_aux === +! The following parameters are used for auxiliary diabatic processes. + +! === module MOM_regularize_layers === + +! === module MOM_opacity === + +! === module MOM_tracer_advect === + +! === module MOM_tracer_hor_diff === + +! === module MOM_neutral_diffusion === +! This module implements neutral diffusion of tracers + +! === module MOM_sum_output === +MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 + ! The run will be stopped, and the day set to a very large value if the velocity + ! is truncated more than MAXTRUNC times between energy saves. Set MAXTRUNC to 0 + ! to stop if there is any truncation of velocities. +DATE_STAMPED_STDOUT = False ! [Boolean] default = True + ! If true, use dates (not times) in messages to stdout + +! === module MOM_surface_forcing === +VARIABLE_WINDS = False ! [Boolean] default = True + ! If true, the winds vary in time after the initialization. +VARIABLE_BUOYFORCE = False ! [Boolean] default = True + ! If true, the buoyancy forcing varies in time after the initialization of the + ! model. +BUOY_CONFIG = "zero" ! + ! The character string that indicates how buoyancy forcing is specified. Valid + ! options include (file), (zero), (linear), (USER), (BFB) and (NONE). +WIND_CONFIG = "zero" ! + ! The character string that indicates how wind forcing is specified. Valid + ! options include (file), (2gyre), (1gyre), (gyres), (zero), and (USER). + +! === module MOM_restart === + +! === module MOM_main (MOM_driver) === +DAYMAX = 1.0 ! [days] + ! The final time of the whole simulation, in units of TIMEUNIT seconds. This + ! also sets the potential end time of the present run segment if the end time is + ! not set via ocean_solo_nml in input.nml. +RESTART_CONTROL = 3 ! default = 1 + ! An integer whose bits encode which restart files are written. Add 2 (bit 1) + ! for a time-stamped file, and odd (bit 0) for a non-time-stamped file. A + ! non-time-stamped restart file is saved at the end of the run segment for any + ! non-negative value. + +! === module MOM_write_cputime === +MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 + ! The maximum amount of cpu time per processor for which MOM should run before + ! saving a restart file and quitting with a return value that indicates that a + ! further run is required to complete the simulation. If automatic restarts are + ! not desired, use a negative value for MAXCPU. MAXCPU has units of wall-clock + ! seconds, so the actual CPU time used is larger by a factor of the number of + ! processors used. + +! === module MOM_file_parser === diff --git a/.testing/_tc4/build_data.py b/.testing/_tc4/build_data.py new file mode 100644 index 0000000000..904db77c7a --- /dev/null +++ b/.testing/_tc4/build_data.py @@ -0,0 +1,68 @@ +import netCDF4 as nc +import numpy as np + +x=nc.Dataset('ocean_hgrid.nc').variables['x'][1::2,1::2] +y=nc.Dataset('ocean_hgrid.nc').variables['y'][1::2,1::2] +zbot=nc.Dataset('topog.nc').variables['depth'][:] +zbot0=zbot.max() + +def t_fc(x,y,z,radius=5.0,tmag=1.0): # a radially symmetric anomaly in the center of the domain. units are meters and degC + ny,nx=x.shape;nz=z.shape[0] + x0=x[int(ny/2),int(nx/2)];y0=y[int(ny/2),int(nx/2)] + tl=np.zeros((nz,ny,nx)) + zb=z[-1] + if len(z)>1: + zd=z/zb + else: + zd=[0.] + for k in np.arange(len(zd)): + r=np.sqrt((x-x0)**2.+(y-y0)**2.) + tl[k,:]=tl[k,:]+(1.0-np.minimum(r/radius,1.0))*tmag*(1.0-zd[k]) + return tl + +ny,nx = x.shape +nz=10;z=(np.arange(nz)*zbot0)/nz + +temp=t_fc(x,y,z) +salt=np.zeros(temp.shape)+35.0 +fl=nc.Dataset('temp_salt_ic.nc','w',format='NETCDF3_CLASSIC') +fl.createDimension('lon',nx) +fl.createDimension('lat',ny) +fl.createDimension('depth',nz) +fl.createDimension('Time',None) +zv=fl.createVariable('depth','f8',('depth')) +lonv=fl.createVariable('lon','f8',('lon')) +latv=fl.createVariable('lat','f8',('lat')) +timev=fl.createVariable('Time','f8',('Time')) +timev.calendar='noleap' +timev.units='days since 0001-01-01 00:00:00.0' +timev.modulo=' ' +tv=fl.createVariable('ptemp','f8',('Time','depth','lat','lon'),fill_value=-1.e20) +sv=fl.createVariable('salt','f8',('Time','depth','lat','lon'),fill_value=-1.e20) +tv[:]=temp[np.newaxis,:] +sv[:]=salt[np.newaxis,:] +zv[:]=z +lonv[:]=x[0,:] +latv[:]=y[:,0] +timev[0]=0. +fl.sync() +fl.close() + + +# Make Sponge forcing file +dampTime=20.0 # days +secDays=8.64e4 +fl=nc.Dataset('sponge.nc','w',format='NETCDF3_CLASSIC') +fl.createDimension('lon',nx) +fl.createDimension('lat',ny) +lonv=fl.createVariable('lon','f8',('lon')) +latv=fl.createVariable('lat','f8',('lat')) +spv=fl.createVariable('Idamp','f8',('lat','lon'),fill_value=-1.e20) +Idamp=np.zeros((ny,nx)) +if dampTime>0.: + Idamp=0.0+1.0/(dampTime*secDays) +spv[:]=Idamp +lonv[:]=x[0,:] +latv[:]=y[:,0] +fl.sync() +fl.close() diff --git a/.testing/_tc4/build_grid.py b/.testing/_tc4/build_grid.py new file mode 100644 index 0000000000..f4f51bd399 --- /dev/null +++ b/.testing/_tc4/build_grid.py @@ -0,0 +1,66 @@ +import netCDF4 as nc +import numpy as np + + +nx=14;ny=10 # grid size +depth0=100. #uniform depth +ds=0.01 # grid resolution at the equator in degrees +Re=6.378e6 # Radius of earth + +topo_=np.zeros((ny,nx))+depth0 +f_topo=nc.Dataset('topog.nc','w',format='NETCDF3_CLASSIC') +ny,nx=topo_.shape +f_topo.createDimension('ny',ny) +f_topo.createDimension('nx',nx) +f_topo.createDimension('ntiles',1) +f_topo.createVariable('depth','f8',('ny','nx')) +f_topo.createVariable('h2','f8',('ny','nx')) +f_topo.variables['depth'][:]=topo_ +f_topo.sync() +f_topo.close() + +x_=np.arange(0,2*nx+1)*ds # units are degrees E +y_=np.arange(0,2*ny+1)*ds # units are degrees N +x,y=np.meshgrid(x_,y_) + +dx=np.zeros((2*ny+1,2*nx)) +dy=np.zeros((2*ny,2*nx+1)) +rad_deg=np.pi/180. +dx[:]=rad_deg*Re*(x[:,1:]-x[:,0:-1])*np.cos(rad_deg*y[:,1:]) +dy[:]=rad_deg*Re*(y[1::,:]-y[0:-1,:]) + +f_sg=nc.Dataset('ocean_hgrid.nc','w',format='NETCDF3_CLASSIC') +f_sg.createDimension('ny',ny*2) +f_sg.createDimension('nx',nx*2) +f_sg.createDimension('nyp',ny*2+1) +f_sg.createDimension('nxp',nx*2+1) +f_sg.createDimension('string',255) +f_sg.createVariable('y','f8',('nyp','nxp')) +f_sg.createVariable('x','f8',('nyp','nxp')) +dyv=f_sg.createVariable('dy','f8',('ny','nxp')) +dxv=f_sg.createVariable('dx','f8',('nyp','nx')) +areav=f_sg.createVariable('area','f8',('ny','nx')) +dxv.units='m' +dyv.units='m' +areav.units='m2' +f_sg.createVariable('angle_dx','f8',('nyp','nxp')) +f_sg.createVariable('tile','S1',('string')) +f_sg.variables['y'].units='degrees' +f_sg.variables['x'].units='degrees' +f_sg.variables['dy'].units='meters' +f_sg.variables['dx'].units='meters' +f_sg.variables['area'].units='m2' +f_sg.variables['angle_dx'].units='degrees' +f_sg.variables['y'][:]=y +f_sg.variables['x'][:]=x +f_sg.variables['dx'][:]=dx +f_sg.variables['dy'][:]=dy +f_sg.variables['area'][:]=0.25*(dx[0:-1,:]+dx[1:,:])*(dy[:,0:-1]+dy[:,1:]) +f_sg.variables['angle_dx'][:]=0. +f_sg.variables['tile'][0] = 't' ## This is stupid +f_sg.variables['tile'][1] = 'i' +f_sg.variables['tile'][2] = 'l' +f_sg.variables['tile'][3] = 'e' +f_sg.variables['tile'][4] = '1' +f_sg.sync() +f_sg.close() diff --git a/.testing/_tc4/diag_table b/.testing/_tc4/diag_table new file mode 100644 index 0000000000..bfc07c25e8 --- /dev/null +++ b/.testing/_tc4/diag_table @@ -0,0 +1,49 @@ +"tc4" +1 1 1 0 0 0 +"prog", 1,"hours",1,"days","Time" + +#This is the field section of the diag_table. + +# Prognostic Ocean fields: +#========================= + +"ocean_model","deptho","deptho","prog","none",.false.,"none",2 +"ocean_model","areacello","areacello","prog","none",.false.,"none",2 +"ocean_model","SSH","SSH","prog","all",.false.,"none",2 +"ocean_model","temp","temp","prog","all",.false.,"none",2 + + +#============================================================================================= +# +#====> This file can be used with diag_manager/v2.0a (or higher) <==== +# +# +# FORMATS FOR FILE ENTRIES (not all input values are used) +# ------------------------ +# +#"file_name", output_freq, "output_units", format, "time_units", "time_long_name", ... +# (opt) new_file_frequecy, (opt) "new_file_freq_units", "new_file_start_date" +# +# +#output_freq: > 0 output frequency in "output_units" +# = 0 output frequency every time step +# =-1 output frequency at end of run +# +#output_units = units used for output frequency +# (years, months, days, minutes, hours, seconds) +# +#time_units = units used to label the time axis +# (days, minutes, hours, seconds) +# +# +# FORMAT FOR FIELD ENTRIES (not all input values are used) +# ------------------------ +# +#"module_name", "field_name", "output_name", "file_name" "time_sampling", time_avg, "other_opts", packing +# +#time_avg = .true. or .false. +# +#packing = 1 double precision +# = 2 float +# = 4 packed 16-bit integers +# = 8 packed 1-byte (not tested?) diff --git a/.testing/_tc4/input.nml b/.testing/_tc4/input.nml new file mode 100644 index 0000000000..29918fbdee --- /dev/null +++ b/.testing/_tc4/input.nml @@ -0,0 +1,27 @@ + &MOM_input_nml + output_directory = './', + input_filename = 'n' + restart_input_dir = 'INPUT/', + restart_output_dir = 'RESTART/', + parameter_filename = 'MOM_input', + 'MOM_override' / + + &diag_manager_nml + flush_nc_files = .true. + / + + &fms_nml + domains_stack_size = 710000, + stack_size = 0 / + + &ocean_domains_nml + / + + &ocean_solo_nml + months = 0 + date_init = 1,1,1,0,0,0 + hours = 0 + minutes = 0 + seconds = 0 + calendar = 'julian' / + diff --git a/.testing/_tc4/prep.bash b/.testing/_tc4/prep.bash new file mode 100644 index 0000000000..181f5081f5 --- /dev/null +++ b/.testing/_tc4/prep.bash @@ -0,0 +1,5 @@ +#!/bin/bash + + +python build_grid.py +python build_data.py From 2d21468692fdd3c78c765562f662c5cfb4fd5647 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 17 Sep 2019 10:07:09 -0400 Subject: [PATCH 067/259] Bugfix test --- .testing/_tc4/MOM_input | 4 ++-- .testing/_tc4/MOM_override | 0 2 files changed, 2 insertions(+), 2 deletions(-) create mode 100644 .testing/_tc4/MOM_override diff --git a/.testing/_tc4/MOM_input b/.testing/_tc4/MOM_input index 93feb3f32c..da0e887a6a 100644 --- a/.testing/_tc4/MOM_input +++ b/.testing/_tc4/MOM_input @@ -15,13 +15,13 @@ C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 ! The heat capacity of sea water, approximated as a constant. This is only used ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 ! definition of conservative temperature. -SAVE_INITIAL_CONDS = True ! [Boolean] default = False +SAVE_INITIAL_CONDS = False ! [Boolean] default = False ! If true, write the initial conditions to a file given by IC_OUTPUT_FILE. ! === module MOM_domains === REENTRANT_X = False ! [Boolean] default = True ! If true, the domain is zonally reentrant. -NIGLOBAL = 10 ! +NIGLOBAL = 14 ! ! The total number of thickness grid points in the x-direction in the physical ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. NJGLOBAL = 10 ! diff --git a/.testing/_tc4/MOM_override b/.testing/_tc4/MOM_override new file mode 100644 index 0000000000..e69de29bb2 From 71acc61ca19360967527668a5dfe847ac49c4a54 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 17 Sep 2019 14:26:37 -0400 Subject: [PATCH 068/259] remove extra blank lines --- src/framework/MOM_horizontal_regridding.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 094005bf7c..0af2b1759b 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -738,11 +738,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t roundoff = 1.e-4 if (.not.spongeDataOngrid) then - if (is_root_pe()) & call time_interp_external(fms_id, Time, data_in, verbose=.true.) - - ! loop through each data level and interpolate to model grid. ! after interpolating, fill in points which will be needed ! to define the layers From 2c23578b86f003a4ba8bae4ed18e192798a878f7 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 17 Sep 2019 14:27:49 -0400 Subject: [PATCH 069/259] Response to comments --- .testing/_tc4/build_grid.py | 16 +++++++--------- .testing/_tc4/prep.bash | 5 ----- 2 files changed, 7 insertions(+), 14 deletions(-) delete mode 100644 .testing/_tc4/prep.bash diff --git a/.testing/_tc4/build_grid.py b/.testing/_tc4/build_grid.py index f4f51bd399..e290fb4c6a 100644 --- a/.testing/_tc4/build_grid.py +++ b/.testing/_tc4/build_grid.py @@ -1,4 +1,5 @@ import netCDF4 as nc +from netCDF4 import stringtochar import numpy as np @@ -26,15 +27,15 @@ dx=np.zeros((2*ny+1,2*nx)) dy=np.zeros((2*ny,2*nx+1)) rad_deg=np.pi/180. -dx[:]=rad_deg*Re*(x[:,1:]-x[:,0:-1])*np.cos(rad_deg*y[:,1:]) -dy[:]=rad_deg*Re*(y[1::,:]-y[0:-1,:]) +dx[:]=rad_deg*Re*(x[:,1:]-x[:,0:-1])*np.cos(0.5*rad_deg*(y[:,0:-1]+y[:,1:])) +dy[:]=rad_deg*Re*(y[1:,:]-y[0:-1,:]) f_sg=nc.Dataset('ocean_hgrid.nc','w',format='NETCDF3_CLASSIC') f_sg.createDimension('ny',ny*2) f_sg.createDimension('nx',nx*2) f_sg.createDimension('nyp',ny*2+1) f_sg.createDimension('nxp',nx*2+1) -f_sg.createDimension('string',255) +f_sg.createDimension('string',5) f_sg.createVariable('y','f8',('nyp','nxp')) f_sg.createVariable('x','f8',('nyp','nxp')) dyv=f_sg.createVariable('dy','f8',('ny','nxp')) @@ -55,12 +56,9 @@ f_sg.variables['x'][:]=x f_sg.variables['dx'][:]=dx f_sg.variables['dy'][:]=dy -f_sg.variables['area'][:]=0.25*(dx[0:-1,:]+dx[1:,:])*(dy[:,0:-1]+dy[:,1:]) +f_sg.variables['area'][:]=0.25*((dx[0:-1,:]+dx[1:,:])*(dy[:,0:-1]+dy[:,1:])) f_sg.variables['angle_dx'][:]=0. -f_sg.variables['tile'][0] = 't' ## This is stupid -f_sg.variables['tile'][1] = 'i' -f_sg.variables['tile'][2] = 'l' -f_sg.variables['tile'][3] = 'e' -f_sg.variables['tile'][4] = '1' +str_=stringtochar(np.array(['tile1'],dtype='S5')) +f_sg.variables['tile'][:] = str_ f_sg.sync() f_sg.close() diff --git a/.testing/_tc4/prep.bash b/.testing/_tc4/prep.bash deleted file mode 100644 index 181f5081f5..0000000000 --- a/.testing/_tc4/prep.bash +++ /dev/null @@ -1,5 +0,0 @@ -#!/bin/bash - - -python build_grid.py -python build_data.py From 5e3d3a2d7d5eb954c69805db40a996a4cb46279c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 17 Sep 2019 16:05:34 -0400 Subject: [PATCH 070/259] blank diag table --- .testing/_tc4/diag_table | 49 +--------------------------------------- 1 file changed, 1 insertion(+), 48 deletions(-) diff --git a/.testing/_tc4/diag_table b/.testing/_tc4/diag_table index bfc07c25e8..e08d2714c2 100644 --- a/.testing/_tc4/diag_table +++ b/.testing/_tc4/diag_table @@ -1,49 +1,2 @@ -"tc4" +"MOM test configuration 4" 1 1 1 0 0 0 -"prog", 1,"hours",1,"days","Time" - -#This is the field section of the diag_table. - -# Prognostic Ocean fields: -#========================= - -"ocean_model","deptho","deptho","prog","none",.false.,"none",2 -"ocean_model","areacello","areacello","prog","none",.false.,"none",2 -"ocean_model","SSH","SSH","prog","all",.false.,"none",2 -"ocean_model","temp","temp","prog","all",.false.,"none",2 - - -#============================================================================================= -# -#====> This file can be used with diag_manager/v2.0a (or higher) <==== -# -# -# FORMATS FOR FILE ENTRIES (not all input values are used) -# ------------------------ -# -#"file_name", output_freq, "output_units", format, "time_units", "time_long_name", ... -# (opt) new_file_frequecy, (opt) "new_file_freq_units", "new_file_start_date" -# -# -#output_freq: > 0 output frequency in "output_units" -# = 0 output frequency every time step -# =-1 output frequency at end of run -# -#output_units = units used for output frequency -# (years, months, days, minutes, hours, seconds) -# -#time_units = units used to label the time axis -# (days, minutes, hours, seconds) -# -# -# FORMAT FOR FIELD ENTRIES (not all input values are used) -# ------------------------ -# -#"module_name", "field_name", "output_name", "file_name" "time_sampling", time_avg, "other_opts", packing -# -#time_avg = .true. or .false. -# -#packing = 1 double precision -# = 2 float -# = 4 packed 16-bit integers -# = 8 packed 1-byte (not tested?) From fac1a0158c9008245005e116c6253e7d49bebe18 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 17 Sep 2019 23:46:58 -0400 Subject: [PATCH 071/259] correct area calculation for a lat-lon grid --- .testing/_tc4/build_grid.py | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/.testing/_tc4/build_grid.py b/.testing/_tc4/build_grid.py index e290fb4c6a..8187e98144 100644 --- a/.testing/_tc4/build_grid.py +++ b/.testing/_tc4/build_grid.py @@ -56,7 +56,18 @@ f_sg.variables['x'][:]=x f_sg.variables['dx'][:]=dx f_sg.variables['dy'][:]=dy -f_sg.variables['area'][:]=0.25*((dx[0:-1,:]+dx[1:,:])*(dy[:,0:-1]+dy[:,1:])) +#Compute the area bounded by lines of constant +#latitude-longitud on a sphere in m2. +dlon=x_[1:]-x_[:-1] +dlon=np.tile(dlon[np.newaxis,:],(2*ny,1)) +y1_=y_[:-1] +y1_=y1_[:,np.newaxis]*rad_deg +y2_=y_[1:] +y2_=y2_[:,np.newaxis]*rad_deg +y1_=np.tile(y1_,(1,2*nx)) +y2_=np.tile(y2_,(1,2*nx)) +area=(rad_deg*Re*Re)*(np.sin(y2_)-np.sin(y1_)) * dlon +f_sg.variables['area'][:]=area f_sg.variables['angle_dx'][:]=0. str_=stringtochar(np.array(['tile1'],dtype='S5')) f_sg.variables['tile'][:] = str_ From 507ac2050216207d70a578096f2ce9f69cdc266e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 18 Sep 2019 16:56:25 +0000 Subject: [PATCH 072/259] Adds dependency on source code - After the first build in .testing, subsequent builds were not triggered when the source code was modified. - By making the path_names file dependent on source code a rebuild of the Makefile and objects is triggered but only out-of-date objects are re-compiled. --- .testing/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 207582e4dc..41fb9110c4 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -66,6 +66,7 @@ else TARGET_CODEBASE = endif +SOURCE = $(wildcard $(BASE)/src/*/*.F90 $(BASE)/src/*/*/*.F90 $(BASE)/config_src/solo_driver/*.F90) #--- # Rules @@ -110,7 +111,7 @@ $(BUILD)/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) $(TARGET_CODEBASE)/config_src/solo_driver \ $(TARGET_CODEBASE)/$(GRID_SRC) -$(BUILD)/%/path_names: $(LIST_PATHS) +$(BUILD)/%/path_names: $(LIST_PATHS) $(SOURCE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l \ $(BASE)/src \ From 404cad026224ac5343a2019c54083764ca27605f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 19 Sep 2019 17:04:00 +0000 Subject: [PATCH 073/259] Reshaped tc3 to be 10x8 - Changed shape of tc3 to be 10x8 to be the same size as tc1 and tc2. This will allow us to re-use static memory executables. --- .testing/tc3/MOM_input | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 430ce24b61..4026665f11 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -35,11 +35,11 @@ NJHALO = 4 ! default = 2 ! y-direction. With STATIC_MEMORY_ this is set as NJHALO_ ! in MOM_memory.h at compile time; without STATIC_MEMORY_ ! the default is NJHALO_ in MOM_memory.h (if defined) or 2. -NIGLOBAL = 13 ! +NIGLOBAL = 10 ! ! The total number of thickness grid points in the ! x-direction in the physical domain. With STATIC_MEMORY_ ! this is set in MOM_memory.h at compile time. -NJGLOBAL = 13 ! +NJGLOBAL = 8 ! ! The total number of thickness grid points in the ! y-direction in the physical domain. With STATIC_MEMORY_ ! this is set in MOM_memory.h at compile time. From a045278a3b08c1529e4837591e61a358d8eeadda Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 19 Sep 2019 18:03:57 +0000 Subject: [PATCH 074/259] Dimension scaling of massout_flux, tracers This patch fixes the dimensional scaling of the following diagnostics: - massout_flux - ideal_age - various DOME derived tracers - Derived tracer diagnostics: - *_adx - *_ady - *_dfx - *_dfx - *h_tendency_2d Many tracer fixes rely on the "flux_" and "conv_" arguments for rescaling, which is probably not the original intended use, and should probably be revised in the future. --- src/core/MOM_forcing_type.F90 | 2 +- src/tracer/DOME_tracer.F90 | 4 ++-- src/tracer/MOM_tracer_registry.F90 | 20 ++++++++++++-------- src/tracer/ideal_age_example.F90 | 3 ++- 4 files changed, 17 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 7df4213a2f..a8c6f7bf1a 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1323,7 +1323,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_massout_flux = register_diag_field('ocean_model', 'massout_flux', diag%axesT1, Time, & 'Net mass flux of freshwater out of the ocean (used in the boundary flux calculation)', & - 'kg m-2') + 'kg m-2', conversion=diag%GV%H_to_kg_m2) handles%id_massin_flux = register_diag_field('ocean_model', 'massin_flux', diag%axesT1, Time, & 'Net mass flux of freshwater into the ocean (used in boundary flux calculation)', 'kg m-2') diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index d820ecf36a..7589f04ed0 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -123,8 +123,8 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! 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, & - restart_CS=restart_CS) + registry_diags=.true., restart_CS=restart_CS, & + flux_units=trim(flux_units), flux_scale=GV%H_to_MKS) ! 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_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 41299be3e8..6a2dd79b5b 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -392,18 +392,20 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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), v_extensive = .true., y_cell_method = 'sum') + trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & + conversion=Tr%flux_scale) Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & - trim(flux_units), v_extensive = .true., x_cell_method = 'sum') + trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + conversion=Tr%flux_scale) Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & - trim(flux_units), v_extensive = .true., conversion=US%L_to_m**2, & - y_cell_method = 'sum') + trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & + conversion=(US%L_to_m**2)*Tr%flux_scale) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive zonal flux" , & - trim(flux_units), v_extensive = .true., conversion=US%L_to_m**2, & - x_cell_method = 'sum') + trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + conversion=(US%L_to_m**2)*Tr%flux_scale) 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), & @@ -508,9 +510,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) var_lname = "Net time tendency for "//lowercase(flux_longname) if (len_trim(Tr%cmor_tendprefix) == 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.) + diag%axesTL, Time, var_lname, conv_units, v_extensive=.true., & + conversion=Tr%conv_scale) 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, & + conversion=Tr%conv_scale) else cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//& trim(flux_longname)//" Content" diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 35975bccb0..a46e42f415 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -176,7 +176,8 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! 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., restart_CS=restart_CS, & - mandatory=.not.CS%tracers_may_reinit) + mandatory=.not.CS%tracers_may_reinit, & + flux_scale=GV%H_to_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 From 2be565f10377604cc3ce4a05a88df3bdcf6a1969 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 19 Sep 2019 17:47:45 +0000 Subject: [PATCH 075/259] Inserts labels in front of output lines on tty - Adds . to all model output on tty so that the log looks like `tc1.dim.z: Total Energy: 43FF5C2A55A02C54 3.6155642564495884E+19`. This helps identify where things are happening or going wrong. - I tested that a failed executable still is detected (error code is passed to make appropriately). --- .testing/Makefile | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 41fb9110c4..2bd59e619b 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -218,13 +218,20 @@ else MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) endif +# Rule to build /ocean.stats. +# $(1) - +# $(2) - +# $(3) - report to codecov +# $(4) - Parameter line for MOM_override +# $(5) - Environment for MPIRUN +# $(6) - Number of PEs define STAT_RULE $$(BASE)/.testing/%/ocean.stats.$(1): $$(BUILD)/$(2)/MOM6 if [ $(3) ]; then find $$(BUILD) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D)/RESTART echo $(4) > $$(@D)/MOM_override - cd $$(@D) && $$(call MPIRUN_CMD,$(5)) -n $(6) $$< 2> debug.out \ - || ! cat debug.out + cd $$(@D) && $$(call MPIRUN_CMD,$(5)) -n $(6) $$< 2> debug.out > std.out \ + || ! sed 's/^/$$*.$(1): /' std.out debug.out && sed 's/^/$$*.$(1): /' std.out cp $$(@D)/ocean.stats $$@ > $$(@D)/MOM_override if [ $(3) ]; then cd $$(BASE) && bash <(curl -s https://codecov.io/bash) -n $$@; fi @@ -264,13 +271,15 @@ $(BASE)/.testing/%/ocean.stats.restart: $(BUILD)/symmetric/MOM6 && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml \ && echo $${daymax} $${timeunit} # Run the first half-period - cd $(@D) && $(MPIRUN) -n 1 $< 2> debug.out + cd $(@D) && $(MPIRUN) -n 1 $< 2> debug.out > std.out \ + || ! sed 's/^/$*.restart1: /' std.out debug.out && sed 's/^/$*.restart1: /' std.out # Setup the next inputs rm -rf $(@D)/INPUT && mv $(@D)/RESTART $(@D)/INPUT mkdir $(@D)/RESTART cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd $(@D) && $(MPIRUN) -n 1 $< 2> debug.out + cd $(@D) && $(MPIRUN) -n 1 $< 2> debug.out > std.out \ + || ! sed 's/^/$*.restart2: /' std.out debug.out && sed 's/^/$*.restart2: /' std.out # Archive the results and cleanup cp $(@D)/ocean.stats $@ rm -rf $(@D)/INPUT From 033cf83dd0ceb66987c7da885cd8e1d4493e93d3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 20 Sep 2019 01:03:00 +0000 Subject: [PATCH 076/259] Combined duplication comments - Rearranged and combined inadvertent duplication of comments - Also fixed two spelling mistakes --- .testing/Makefile | 26 +++++++++----------------- 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 2bd59e619b..5576892046 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -202,16 +202,8 @@ $(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) #--- # Test run output files -#(1): Configuration name -#(2): Executable type -#(3): Enable coverage flag -#(4): MOM_override configuration -#(5): Environment variables -#(6): Number of MPI ranks - -# Simple function for generalised Slurm (srun) and OpenMPI (mpirun) support -# (1): Environment variables - +# Simple function for generalized Slurm (srun) and OpenMPI (mpirun) support +# $(1): Environment variables ifeq ($(MPIRUN), srun) MPIRUN_CMD=$(1) $(MPIRUN) else @@ -219,12 +211,12 @@ MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) endif # Rule to build /ocean.stats. -# $(1) - -# $(2) - -# $(3) - report to codecov -# $(4) - Parameter line for MOM_override -# $(5) - Environment for MPIRUN -# $(6) - Number of PEs +# $(1): Test configuration name +# $(2): Executable type +# $(3): Enable coverage flag +# $(4): MOM_override configuration +# $(5): Environment variables +# $(6): Number of MPI ranks define STAT_RULE $$(BASE)/.testing/%/ocean.stats.$(1): $$(BUILD)/$(2)/MOM6 if [ $(3) ]; then find $$(BUILD) -name *.gcda -exec rm -f '{}' \; ; fi @@ -254,7 +246,7 @@ $(eval $(call STAT_RULE,dim.l,symmetric,,L_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) -# Restart tests require signicant preprocessing, and are handled separately. +# Restart tests require significant preprocessing, and are handled separately. $(BASE)/.testing/%/ocean.stats.restart: $(BUILD)/symmetric/MOM6 # Cleanup mkdir -p $(@D)/RESTART From 8f7cb968b4782aca92ac704246bb17dfc10d7271 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 20 Sep 2019 01:09:11 +0000 Subject: [PATCH 077/259] Hide new temporary file --- .testing/.gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.testing/.gitignore b/.testing/.gitignore index a096823fcd..8e2be60894 100644 --- a/.testing/.gitignore +++ b/.testing/.gitignore @@ -13,3 +13,4 @@ GOLD_IC.nc debug.out chksum_diag.* config.mk +std.out* From 2097fcda246e25037bd73007974a3af2a83fd250 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 19 Sep 2019 17:04:00 +0000 Subject: [PATCH 078/259] Reshaped tc3 to be 10x8 - Changed shape of tc3 to be 10x8 to be the same size as tc1 and tc2. This will allow us to re-use static memory executables. --- .testing/tc3/MOM_input | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index 430ce24b61..4026665f11 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -35,11 +35,11 @@ NJHALO = 4 ! default = 2 ! y-direction. With STATIC_MEMORY_ this is set as NJHALO_ ! in MOM_memory.h at compile time; without STATIC_MEMORY_ ! the default is NJHALO_ in MOM_memory.h (if defined) or 2. -NIGLOBAL = 13 ! +NIGLOBAL = 10 ! ! The total number of thickness grid points in the ! x-direction in the physical domain. With STATIC_MEMORY_ ! this is set in MOM_memory.h at compile time. -NJGLOBAL = 13 ! +NJGLOBAL = 8 ! ! The total number of thickness grid points in the ! y-direction in the physical domain. With STATIC_MEMORY_ ! this is set in MOM_memory.h at compile time. From 18cf25843fef3daab09ca71c300767a6c6e07a92 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 19 Sep 2019 22:44:12 +0000 Subject: [PATCH 079/259] Correct tyope in .testing/README.md --- .testing/README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.testing/README.md b/.testing/README.md index a9289a87dd..fbcfdc0a32 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -56,7 +56,7 @@ Model state is currently defined by the `ocean.stats` output file, which reports the total energy (per unit mass) at machine precision alongside similar global metrics, such as mass or mean sea level, at lower precision. -Clhecksums for every available diagnostic are also compared and the Makefile +Checksums for every available diagnostic are also compared and the Makefile will report any differences, but such differences are not yet considered a fail condition. @@ -138,7 +138,7 @@ This will run through the following tests: - `test.restarts`: Resubmission by restarts - `test.repros`: Optimized (REPRO) and unoptimized (DEBUG) compilation - `test.nans`: NaN initialization of allocated arrays -- `test.dims`: Dimensional scaling (length, time, thichkness, depth) +- `test.dims`: Dimensional scaling (length, time, thickness, depth) To enable the regression tests, use `DO_REGRESSION_TEST=true`. ``` @@ -170,7 +170,7 @@ The following test configurations (TCs) are supported: Code coverage reports the lines of code which have been tested, and can explicitly demonstrate when a particular operation is untested. -Coverage is measued using `gcov` and is reported for TCs using the `symmetric` +Coverage is measured using `gcov` and is reported for TCs using the `symmetric` executable. Coverage reporting is optionally sent to the `codecov.io` site. From cb51c317796218b50760008c0e9f7e05c9a4dff5 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 19 Sep 2019 22:46:12 +0000 Subject: [PATCH 080/259] Add line describing tc1.a to .testing/README.md - Also changed tense of labels to match directories --- .testing/README.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/.testing/README.md b/.testing/README.md index fbcfdc0a32..2e51ae22d4 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -159,10 +159,11 @@ fail if the answers differ from this build. The following test configurations (TCs) are supported: -- TC0: Unit testing of various model components, based on `unit_tests` -- TC1: A low-resolution version of the `benchmark` configuration -- TC2: An ALE configuration based on TC1 -- TC3: An open-boundary condition (OBC) test based on `circle_obcs` +- tc0: Unit testing of various model components, based on `unit_tests` +- tc1: A low-resolution version of the `benchmark` configuration + - tc1.a: Use the un-split mode with Runge-Kutta 3 time integration +- tc2: An ALE configuration based on tc1 +- tc3: An open-boundary condition (OBC) test based on `circle_obcs` ## Code coverage From ec0316eb155a8ad2c6fd5b503878ff511540c302 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 20 Sep 2019 01:50:39 +0000 Subject: [PATCH 081/259] Add tc1.b - Similar to tc1.a but uses RK2 instead of RK3 for time integration --- .testing/README.md | 1 + .testing/tc1.b/MOM_input | 1 + .testing/tc1.b/MOM_override | 0 .testing/tc1.b/MOM_tc_variant | 2 ++ .testing/tc1.b/diag_table | 1 + .testing/tc1.b/input.nml | 20 ++++++++++++++++++++ 6 files changed, 25 insertions(+) create mode 120000 .testing/tc1.b/MOM_input create mode 100644 .testing/tc1.b/MOM_override create mode 100644 .testing/tc1.b/MOM_tc_variant create mode 120000 .testing/tc1.b/diag_table create mode 100644 .testing/tc1.b/input.nml diff --git a/.testing/README.md b/.testing/README.md index 2e51ae22d4..551b9a617f 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -162,6 +162,7 @@ The following test configurations (TCs) are supported: - tc0: Unit testing of various model components, based on `unit_tests` - tc1: A low-resolution version of the `benchmark` configuration - tc1.a: Use the un-split mode with Runge-Kutta 3 time integration + - tc1.b: Use the un-split mode with Runge-Kutta 2 time integration - tc2: An ALE configuration based on tc1 - tc3: An open-boundary condition (OBC) test based on `circle_obcs` diff --git a/.testing/tc1.b/MOM_input b/.testing/tc1.b/MOM_input new file mode 120000 index 0000000000..dca928737e --- /dev/null +++ b/.testing/tc1.b/MOM_input @@ -0,0 +1 @@ +../tc1/MOM_input \ No newline at end of file diff --git a/.testing/tc1.b/MOM_override b/.testing/tc1.b/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc1.b/MOM_tc_variant b/.testing/tc1.b/MOM_tc_variant new file mode 100644 index 0000000000..8d821691f3 --- /dev/null +++ b/.testing/tc1.b/MOM_tc_variant @@ -0,0 +1,2 @@ +#override SPLIT=False +#override USE_RK2=True diff --git a/.testing/tc1.b/diag_table b/.testing/tc1.b/diag_table new file mode 120000 index 0000000000..bf2ad677b6 --- /dev/null +++ b/.testing/tc1.b/diag_table @@ -0,0 +1 @@ +../tc1/diag_table \ No newline at end of file diff --git a/.testing/tc1.b/input.nml b/.testing/tc1.b/input.nml new file mode 100644 index 0000000000..3c7dcf7bea --- /dev/null +++ b/.testing/tc1.b/input.nml @@ -0,0 +1,20 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_tc_variant', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ From df92581ec3d6bb9c6ee35a75e3a320b25c29f060 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 20 Sep 2019 02:05:11 +0000 Subject: [PATCH 082/259] Added tc2.a variant of tc2 - Turned tides off in tc2.a - Uses different remapping scheme, sigma coordinate and different topography. --- .testing/README.md | 3 ++- .testing/tc2.a/MOM_input | 1 + .testing/tc2.a/MOM_override | 0 .testing/tc2.a/MOM_tc_variant | 3 +++ .testing/tc2.a/diag_table | 1 + .testing/tc2.a/input.nml | 20 ++++++++++++++++++++ .testing/tc2/MOM_input | 12 ------------ .testing/tc2/MOM_tc_variant | 12 ++++++++++++ .testing/tc2/input.nml | 1 + 9 files changed, 40 insertions(+), 13 deletions(-) create mode 120000 .testing/tc2.a/MOM_input create mode 100644 .testing/tc2.a/MOM_override create mode 100644 .testing/tc2.a/MOM_tc_variant create mode 120000 .testing/tc2.a/diag_table create mode 100644 .testing/tc2.a/input.nml create mode 100644 .testing/tc2/MOM_tc_variant diff --git a/.testing/README.md b/.testing/README.md index 551b9a617f..5cd190ef25 100644 --- a/.testing/README.md +++ b/.testing/README.md @@ -163,7 +163,8 @@ The following test configurations (TCs) are supported: - tc1: A low-resolution version of the `benchmark` configuration - tc1.a: Use the un-split mode with Runge-Kutta 3 time integration - tc1.b: Use the un-split mode with Runge-Kutta 2 time integration -- tc2: An ALE configuration based on tc1 +- tc2: An ALE configuration based on tc1 with tides + - tc2.a: Use sigma, PPM_H4 and no tides - tc3: An open-boundary condition (OBC) test based on `circle_obcs` diff --git a/.testing/tc2.a/MOM_input b/.testing/tc2.a/MOM_input new file mode 120000 index 0000000000..b0cf8cd51c --- /dev/null +++ b/.testing/tc2.a/MOM_input @@ -0,0 +1 @@ +../tc2/MOM_input \ No newline at end of file diff --git a/.testing/tc2.a/MOM_override b/.testing/tc2.a/MOM_override new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.testing/tc2.a/MOM_tc_variant b/.testing/tc2.a/MOM_tc_variant new file mode 100644 index 0000000000..d48fa53507 --- /dev/null +++ b/.testing/tc2.a/MOM_tc_variant @@ -0,0 +1,3 @@ +#override TOPO_CONFIG = "spoon" +#override REMAPPING_SCHEME = "PPM_H4" +#override REGRIDDING_COORDINATE_MODE = "SIGMA" diff --git a/.testing/tc2.a/diag_table b/.testing/tc2.a/diag_table new file mode 120000 index 0000000000..fcf2284f5f --- /dev/null +++ b/.testing/tc2.a/diag_table @@ -0,0 +1 @@ +../tc2/diag_table \ No newline at end of file diff --git a/.testing/tc2.a/input.nml b/.testing/tc2.a/input.nml new file mode 100644 index 0000000000..3c7dcf7bea --- /dev/null +++ b/.testing/tc2.a/input.nml @@ -0,0 +1,20 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_tc_variant', + 'MOM_override', +/ + +&diag_manager_nml +/ + +&fms_nml + clock_grain = 'ROUTINE' + clock_flags = 'SYNC' + domains_stack_size = 955296 + stack_size = 0 +/ diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 9b36f2675c..c037648d95 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -319,18 +319,6 @@ SMAG_BI_CONST = 0.06 ! [nondim] default = 0.0 ENERGETICS_SFC_PBL = True DO_GEOTHERMAL = True GEOTHERMAL_SCALE = 0.05 -TIDES = True -TIDE_M2 = True -TIDE_S2 = True -TIDE_N2 = True -TIDE_K2 = True -TIDE_K1 = True -TIDE_O1 = True -TIDE_P1 = True -TIDE_Q1 = True -TIDE_MF = True -TIDE_MM = True -TIDE_SAL_SCALAR_VALUE = 1. USE_NEUTRAL_DIFFUSION = True DYNAMIC_VISCOUS_ML = True ! [Boolean] default = False ! If true, use a bulk Richardson number criterion to diff --git a/.testing/tc2/MOM_tc_variant b/.testing/tc2/MOM_tc_variant new file mode 100644 index 0000000000..8cdbf69de8 --- /dev/null +++ b/.testing/tc2/MOM_tc_variant @@ -0,0 +1,12 @@ +TIDES = True +TIDE_M2 = True +TIDE_S2 = True +TIDE_N2 = True +TIDE_K2 = True +TIDE_K1 = True +TIDE_O1 = True +TIDE_P1 = True +TIDE_Q1 = True +TIDE_MF = True +TIDE_MM = True +TIDE_SAL_SCALAR_VALUE = 1. diff --git a/.testing/tc2/input.nml b/.testing/tc2/input.nml index 54b26920b1..3c7dcf7bea 100644 --- a/.testing/tc2/input.nml +++ b/.testing/tc2/input.nml @@ -5,6 +5,7 @@ restart_output_dir = 'RESTART/' parameter_filename = 'MOM_input', + 'MOM_tc_variant', 'MOM_override', / From 3cd55699f3f5a32f90b528f4db3fcd053c1468ad Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 20 Sep 2019 18:27:18 -0400 Subject: [PATCH 083/259] Test run work and results dir; relative path rules This patch consists of three changes to the test suite: - Tests are now run in dedicated work directories. This allows for parallel execution of tests inside of make. Unexpected improvements are a 3-4x speedup on test time, and the disappearance of several anomalous "negative zero" issues which were otherwise unreproducible outside of the test, suggesting that replacing the serial runs inside of the tc directories has resolved some otherwise unknown problems. - Makefile rules for running tests are now defined relative to the .testing directory, rather than an explicit base directory based on the path of the Makefile. Although this method is slightly less robust and slightly more prone to error, it makes it easier to build and run individual files within the project. Build paths are still absolute, and will be updated in a separate commit. - Test output is now stored in a `results` directory, rather than inside the tc* configuration directories. --- .testing/.gitignore | 17 ++------- .testing/Makefile | 84 +++++++++++++++++++++++++-------------------- 2 files changed, 48 insertions(+), 53 deletions(-) diff --git a/.testing/.gitignore b/.testing/.gitignore index 8e2be60894..441e73b8e8 100644 --- a/.testing/.gitignore +++ b/.testing/.gitignore @@ -1,16 +1,3 @@ -available_diags.* -CPU_stats -chksum_diag -exitcode -logfile.*.out -MOM_parameter_doc.* -ocean_geometry.nc -ocean.stats* -RESTART/ -time_stamp.out -Vertical_coordinate.nc -GOLD_IC.nc -debug.out -chksum_diag.* config.mk -std.out* +work/ +results/ diff --git a/.testing/Makefile b/.testing/Makefile index 5576892046..a567786dd2 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -175,12 +175,12 @@ test.dims: $(foreach c,$(CONFIGS),$(foreach d,t l h z,$(c).dim.$(d) $(c).dim.$(d # NOTE: chksum_diag return code of cmp is currently ignored since many fail! define CMP_RULE -.PRECIOUS: $(foreach b,$(2),$(BASE)/.testing/%/ocean.stats.$(b)) -%.$(1): $(foreach b,$(2),$(BASE)/.testing/%/ocean.stats.$(b)) +.PRECIOUS: $(foreach b,$(2),results/%/ocean.stats.$(b)) +%.$(1): $(foreach b,$(2),results/%/ocean.stats.$(b)) cmp $$^ -.PRECIOUS: $(foreach b,$(2),$(BASE)/.testing/%/chksum_diag.$(b)) -%.$(1).diag: $(foreach b,$(2),$(BASE)/.testing/%/chksum_diag.$(b)) +.PRECIOUS: $(foreach b,$(2),results/%/chksum_diag.$(b)) +%.$(1).diag: $(foreach b,$(2),results/%/chksum_diag.$(b)) cmp $$^ || true endef @@ -192,8 +192,8 @@ $(eval $(call CMP_RULE,nan,symmetric nan)) $(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) # Restart tests only compare the final stat record -.PRECIOUS: $(foreach b,symmetric restart,$(BASE)/.testing/%/ocean.stats.$(b)) -%.restart: $(foreach b,symmetric restart,$(BASE)/.testing/%/ocean.stats.$(b)) +.PRECIOUS: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) +%.restart: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) # TODO: chksum_diag parsing of restart files @@ -210,7 +210,7 @@ else MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) endif -# Rule to build /ocean.stats. +# Rule to build results//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type # $(3): Enable coverage flag @@ -218,18 +218,22 @@ endif # $(5): Environment variables # $(6): Number of MPI ranks define STAT_RULE -$$(BASE)/.testing/%/ocean.stats.$(1): $$(BUILD)/$(2)/MOM6 - if [ $(3) ]; then find $$(BUILD) -name *.gcda -exec rm -f '{}' \; ; fi - mkdir -p $$(@D)/RESTART - echo $(4) > $$(@D)/MOM_override - cd $$(@D) && $$(call MPIRUN_CMD,$(5)) -n $(6) $$< 2> debug.out > std.out \ - || ! sed 's/^/$$*.$(1): /' std.out debug.out && sed 's/^/$$*.$(1): /' std.out - cp $$(@D)/ocean.stats $$@ - > $$(@D)/MOM_override - if [ $(3) ]; then cd $$(BASE) && bash <(curl -s https://codecov.io/bash) -n $$@; fi - -$$(BASE)/.testing/%/chksum_diag.$(1): $$(BASE)/.testing/%/ocean.stats.$(1) - cp $$(@D)/chksum_diag $$@ +results/%/ocean.stats.$(1): ../build/$(2)/MOM6 + if [ $(3) ]; then find ../build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi + mkdir -p work/$$*/$(1) + cp -rL $$*/* work/$$*/$(1) + mkdir -p work/$$*/$(1)/RESTART + echo $(4) > work/$$*/$(1)/MOM_override + cd work/$$*/$(1) && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> debug.out > std.out \ + || ! sed 's/^/$$*.$(1): /' std.out debug.out \ + && sed 's/^/$$*.$(1): /' std.out + mkdir -p $$(@D) + cp work/$$*/$(1)/ocean.stats $$@ + if [ $(3) ]; then cd .. && bash <(curl -s https://codecov.io/bash) -n $$@; fi + +results/%/chksum_diag.$(1): results/%/ocean.stats.$(1) + mkdir -p $$(@D) + cp work/$$*/$(1)/chksum_diag $$@ endef # Define $(,) as comma escape character @@ -247,14 +251,14 @@ $(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) # Restart tests require significant preprocessing, and are handled separately. -$(BASE)/.testing/%/ocean.stats.restart: $(BUILD)/symmetric/MOM6 - # Cleanup - mkdir -p $(@D)/RESTART - git checkout $(@D)/input.nml - > $(@D)/MOM_override +results/%/ocean.stats.restart: ../build/symmetric/MOM6 + rm -rf work/$*/restart + mkdir -p work/$*/restart + cp -rL $*/* work/$*/restart + mkdir work/$*/restart/RESTART # Generate the half-period input namelist # TODO: Assumes runtime set by DAYMAX, will fail if set by input.nml - cd $(@D) \ + cd work/$*/restart \ && daymax=$$(grep DAYMAX MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ && timeunit=$$(grep TIMEUNIT MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ @@ -263,19 +267,20 @@ $(BASE)/.testing/%/ocean.stats.restart: $(BUILD)/symmetric/MOM6 && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml \ && echo $${daymax} $${timeunit} # Run the first half-period - cd $(@D) && $(MPIRUN) -n 1 $< 2> debug.out > std.out \ - || ! sed 's/^/$*.restart1: /' std.out debug.out && sed 's/^/$*.restart1: /' std.out + cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug.out > std.out \ + || ! sed 's/^/$*.restart1: /' std.out debug.out \ + && sed 's/^/$*.restart1: /' std.out # Setup the next inputs - rm -rf $(@D)/INPUT && mv $(@D)/RESTART $(@D)/INPUT - mkdir $(@D)/RESTART - cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml + cd work/$*/restart && rm -rf INPUT && mv RESTART INPUT + mkdir work/$*/restart/RESTART + cd work/$*/restart && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd $(@D) && $(MPIRUN) -n 1 $< 2> debug.out > std.out \ - || ! sed 's/^/$*.restart2: /' std.out debug.out && sed 's/^/$*.restart2: /' std.out + cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug.out > std.out \ + || ! sed 's/^/$*.restart2: /' std.out debug.out \ + && sed 's/^/$*.restart2: /' std.out # Archive the results and cleanup - cp $(@D)/ocean.stats $@ - rm -rf $(@D)/INPUT - git checkout $(@D)/input.nml + mkdir -p $(@D) + cp work/$*/restart/ocean.stats $@ # TODO: Restart checksum diagnostics @@ -283,9 +288,12 @@ $(BASE)/.testing/%/ocean.stats.restart: $(BUILD)/symmetric/MOM6 #---- .PHONY: clean clean: clean.stats - rm -rf $(BUILD) + @# Assert that we are in .testing for recursive delete + @[ $$(basename $$(pwd)) = .testing ] + rm -rf ../build .PHONY: clean.stats clean.stats: - find $(BASE)/.testing -name ocean.stats* -exec rm {} \; - find $(BASE)/.testing -name chksum_diag* -exec rm {} \; + @# Assert that we are in .testing for recursive delete + @[ $$(basename $$(pwd)) = .testing ] + rm -rf work results From 5dcdacc2fa33b428c96259c44a530d345ed390d7 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 24 Sep 2019 16:21:23 -0600 Subject: [PATCH 084/259] Bugfix: Protect recalculation of interface values In the discontinuous mode of neutral diffusion, the edge values need to be evaluated in the same way that the 'polynomial' evaluation returns which might be different at roundoff. This was accidentally outside of the `if CS%discontinuous` block and was moved inside --- src/tracer/MOM_neutral_diffusion.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 58dee6eec1..ae17f8c9a8 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -309,16 +309,16 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) 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, h_neglect, h_neglect_edge ) + ! In the current ALE formulation, interface values are not exactly at the 0. or 1. of the + ! polynomial reconstructions + do k=1,G%ke + CS%T_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 0. ) + CS%T_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 1. ) + CS%S_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 0. ) + CS%S_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 1. ) + enddo endif enddo - ! In the current ALE formulation, interface values are not exactly at the 0. or 1. of the - ! polynomial reconstructions - do k=1,G%ke - CS%T_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 0. ) - CS%T_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_T(i,j,k,:), CS%deg+1, 1. ) - CS%S_i(i,j,k,1) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 0. ) - CS%S_i(i,j,k,2) = evaluation_polynomial( CS%ppoly_coeffs_S(i,j,k,:), CS%deg+1, 1. ) - enddo ! Continuous reconstruction if (CS%continuous_reconstruction) then From 0abd134ea2f9042aa8ea3af4627db8c199405d23 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 26 Sep 2019 10:23:51 -0400 Subject: [PATCH 085/259] Report negative zero min/max as positive This patch addresses the inconsistency of signed zero in the minimum and maximum values used in checksum report. The behavior of the Fortran intrinsic min() and our MPI library's implementation of MPI_Reduce with MPI_MIN can give different results for different values of signed zero, e.g. min(0,-0) vs min(-0,0). Additionally, the MPI_Reduce result appears to not consistenty follow these rules in more complex MPI calculations. Due to these issues, we add the result to positive zero to ensure that any negative zero results are reported as positive. --- .testing/Makefile | 4 ++-- src/framework/MOM_checksums.F90 | 5 ++++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index a567786dd2..8bad469a23 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -181,7 +181,7 @@ define CMP_RULE .PRECIOUS: $(foreach b,$(2),results/%/chksum_diag.$(b)) %.$(1).diag: $(foreach b,$(2),results/%/chksum_diag.$(b)) - cmp $$^ || true + cmp $$^ endef $(eval $(call CMP_RULE,regression,symmetric target)) @@ -255,7 +255,7 @@ results/%/ocean.stats.restart: ../build/symmetric/MOM6 rm -rf work/$*/restart mkdir -p work/$*/restart cp -rL $*/* work/$*/restart - mkdir work/$*/restart/RESTART + mkdir -p work/$*/restart/RESTART # Generate the half-period input namelist # TODO: Assumes runtime set by DAYMAX, will fail if set by input.nml cd work/$*/restart \ diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index c6a23667db..0f2db2c955 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -1822,8 +1822,11 @@ subroutine chk_sum_msg3(fmsg, aMean, aMin, aMax, mesg, iounit) real, intent(in) :: aMax !< The maximum value of the array integer, intent(in) :: iounit !< Checksum logger IO unit + ! NOTE: We add zero to aMin and aMax to remove any negative zeros. + ! This is due to inconsistencies of signed zero in local vs MPI calculations. + if (is_root_pe()) write(iounit, '(A,3(A,ES25.16,1X),A)') & - fmsg, " mean=", aMean, "min=", aMin, "max=", aMax, trim(mesg) + fmsg, " mean=", aMean, "min=", (0. + aMin), "max=", (0. + aMax), trim(mesg) end subroutine chk_sum_msg3 !> MOM_checksums_init initializes the MOM_checksums module. As it happens, the From 74cc9bb0793a22a047e811d245e653c4d692621a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Sep 2019 11:19:01 -0400 Subject: [PATCH 086/259] +Add optional scale argument to calculate_density Added a new optional scale argument to calculate_density, calculate_spec_vel calculate_density_derivs, calculate_density_second_derivs, and calculate_specific_vol_derivs, to rescale the densities or related variables. All answers are bitwise identical, but there are new optional arguments to public interfaces. --- src/equation_of_state/MOM_EOS.F90 | 165 +++++++++++++++++++++--------- 1 file changed, 118 insertions(+), 47 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index d3b056827b..e3fd3383b4 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -130,13 +130,15 @@ module MOM_EOS !> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) +subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") @@ -158,19 +160,26 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) "calculate_density_scalar: EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then + rho = scale * rho + endif ; endif + end subroutine calculate_density_scalar !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref) +subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] + real, dimension(:), intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] integer, intent(in) :: start !< Start index for computation integer, intent(in) :: npts !< Number of point to compute type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") @@ -192,17 +201,23 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re "calculate_density_array: EOS%form_of_EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then + do j=start,start+npts-1 ; rho(j) = scale * rho(j) ; enddo + endif ; endif + end subroutine calculate_density_array !> Calls the appropriate subroutine to calculate specific volume of sea water !! for scalar inputs. -subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref) +subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: specvol !< specific volume (in-situ if pressure is local) [m3 kg-1] + real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume + !! from m3 kg-1 to the desired units [kg m-3 R-1] real :: rho @@ -231,24 +246,30 @@ subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref) "calculate_spec_vol_scalar: EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then + specvol = scale * specvol + endif ; endif + end subroutine calculate_spec_vol_scalar !> Calls the appropriate subroutine to calculate the specific volume of sea water !! for 1-D array inputs. -subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) +subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref, scale) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface !! [degC]. real, dimension(:), intent(in) :: S !< salinity [ppt]. real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: specvol !< in situ specific volume [kg m-3]. + real, dimension(:), intent(out) :: specvol !< in situ specific volume [kg m-3] or [R-1 ~> m3 kg-1]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume + !! from m3 kg-1 to the desired units [kg m-3 R-1] real, dimension(size(specvol)) :: rho - + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_spec_vol_array called with an unassociated EOS_type EOS.") @@ -275,6 +296,10 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + specvol(j) = scale * specvol(j) + enddo ; endif ; endif + end subroutine calculate_spec_vol_array @@ -333,17 +358,20 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS) end subroutine calculate_TFreeze_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. -subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS) +subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. + !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1]. real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1]. + !! in [kg m-3 ppt-1] or [R degC-1 ~> kg m-3 ppt-1]. integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") @@ -365,26 +393,34 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + drho_dT(j) = scale * drho_dT(j) + drho_dS(j) = scale * drho_dS(j) + enddo ; endif ; endif + end subroutine calculate_density_derivs_array !> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar !! to a one-element array -subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS) +subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] real, intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. + !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1]. + !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1]. type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_WRIGHT) call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS) case (EOS_TEOS10) @@ -394,27 +430,35 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then + drho_dT = scale * drho_dT + drho_dS = scale * drho_dS + endif ; endif + end subroutine calculate_density_derivs_scalar !> Calls the appropriate subroutine to calculate density second derivatives for 1-D array inputs. subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & - drho_dS_dP, drho_dT_dP, start, npts, EOS) + drho_dS_dP, drho_dT_dP, start, npts, EOS, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect - !! to S [kg m-3 ppt-2] - real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with respcct - !! to T [kg m-3 ppt-1 degC-1] - real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect - !! to T [kg m-3 degC-2] - real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect - !! to pressure [kg m-3 ppt-1 Pa-1] - real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect - !! to pressure [kg m-3 degC-1 Pa-1] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S + !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] + real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with respect to T + !! [kg m-3 ppt-1 degC-1] or [R ppt-1 degC-1 ~> kg m-3 ppt-1 degC-1] + real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T + !! [kg m-3 degC-2] or [R degC-2 ~> kg m-3 degC-2] + real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure + !! [kg m-3 ppt-1 Pa-1] or [R ppt-1 Pa-1 ~> kg m-3 ppt-1 Pa-1] + real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure + !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") @@ -434,25 +478,35 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + drho_dS_dS(j) = scale * drho_dS_dS(j) + drho_dS_dT(j) = scale * drho_dS_dT(j) + drho_dT_dT(j) = scale * drho_dT_dT(j) + drho_dS_dP(j) = scale * drho_dS_dP(j) + drho_dT_dP(j) = scale * drho_dT_dP(j) + enddo ; endif ; endif + end subroutine calculate_density_second_derivs_array !> Calls the appropriate subroutine to calculate density second derivatives for scalar nputs. subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & - drho_dS_dP, drho_dT_dP, EOS) + drho_dS_dP, drho_dT_dP, EOS, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect - !! to S [kg m-3 ppt-2] - real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respcct - !! to T [kg m-3 ppt-1 degC-1] - real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect - !! to T [kg m-3 degC-2] - real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect - !! to pressure [kg m-3 ppt-1 Pa-1] - real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect - !! to pressure [kg m-3 degC-1 Pa-1] - type(EOS_type), pointer :: EOS !< Equation of state structure + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S + !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] + real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respect to T + !! [kg m-3 ppt-1 degC-1] or [R ppt-1 degC-1 ~> kg m-3 ppt-1 degC-1] + real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T + !! [kg m-3 degC-2] or [R degC-2 ~> kg m-3 degC-2] + real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure + !! [kg m-3 ppt-1 Pa-1] or [R ppt-1 Pa-1 ~> kg m-3 ppt-1 Pa-1] + real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure + !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") @@ -472,20 +526,31 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then + drho_dS_dS = scale * drho_dS_dS + drho_dS_dT = scale * drho_dS_dT + drho_dT_dT = scale * drho_dT_dT + drho_dS_dP = scale * drho_dS_dP + drho_dT_dP = scale * drho_dT_dP + endif ; endif + end subroutine calculate_density_second_derivs_scalar !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. -subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) +subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] real, dimension(:), intent(out) :: dSV_dT !< The partial derivative of specific volume with potential - !! temperature [m3 kg-1 degC-1]. + !! temperature [m3 kg-1 degC-1] or [R-1 degC-1 ~> m3 kg-1 degC-1] real, dimension(:), intent(out) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [m3 kg-1 ppt-1]. - integer, intent(in) :: start !< Starting index within the array - integer, intent(in) :: npts !< The number of values to calculate - type(EOS_type), pointer :: EOS !< Equation of state structure + !! [m3 kg-1 ppt-1] or [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + integer, intent(in) :: start !< Starting index within the array + integer, intent(in) :: npts !< The number of values to calculate + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume + !! from m3 kg-1 to the desired units [kg m-3 R-1] + ! Local variables real, dimension(size(T)) :: dRho_dT, dRho_dS, rho integer :: j @@ -520,6 +585,12 @@ subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + dSV_dT(j) = scale * dSV_dT(j) + dSV_dS(j) = scale * dSV_dS(j) + enddo ; endif ; endif + + end subroutine calculate_specific_vol_derivs !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. From d4c2dfb433cc397561cb9a614766f6269c717fa8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Sep 2019 11:19:21 -0400 Subject: [PATCH 087/259] +Rescale BML densities via calculate_density calls Rescale bulkmixedlayer densities and their derivatives via the calls to calculate_density and calculate_density_derivs. All answers are bitwise identical. --- .../vertical/MOM_bulk_mixed_layer.F90 | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index ea7a740df5..5eaff15866 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -468,22 +468,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, p_ref(i) = p_ref(i) + 0.5*GV%H_to_Pa*h(i,k) enddo ; enddo call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, & - is, ie-is+1, tv%eqn_of_state) + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, & - is, ie-is+1, tv%eqn_of_state) - if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie - dR0_dT(i) = US%kg_m3_to_R * dR0_dT(i) ; dR0_dS(i) = US%kg_m3_to_R * dR0_dS(i) - dRcv_dT(i) = US%kg_m3_to_R * dRcv_dT(i) ; dRcv_dS(i) = US%kg_m3_to_R * dRcv_dS(i) - enddo ; endif + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do k=1,nz call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), is, ie-is+1, & - tv%eqn_of_state) + tv%eqn_of_state, scale=US%kg_m3_to_R) call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & - ie-is+1, tv%eqn_of_state) - if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie - R0(i,k) = US%kg_m3_to_R * R0(i,k) - Rcv(i,k) = US%kg_m3_to_R * Rcv(i,k) - enddo ; endif + ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) From 4156851268817b92b624e2a7c8d1271d80d8e402 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Sep 2019 17:56:39 -0400 Subject: [PATCH 088/259] Rescaled density units in MOM_entrain_diffusive Rescaled density units in MOM_entrain_diffusive for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_entrain_diffusive.F90 | 98 ++++++++++--------- 1 file changed, 51 insertions(+), 47 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index a4d8e985cf..baebe570e4 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -35,6 +35,7 @@ module MOM_entrain_diffusive !! calculate the diapycnal entrainment. real :: Tolerance_Ent !< The tolerance with which to solve for entrainment values !! [H ~> m or kg m-2]. + real :: Rho_sig_off !< The offset between potential density and a sigma value [R ~> kg m-3] type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. integer :: id_Kd = -1 !< Diagnostic ID for diffusivity @@ -111,7 +112,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! layer after the effects of boundary conditions are ! considered [Z2 T-1 ~> m2 s-1]. diff_work ! The work actually done by diffusion across each - ! interface [W m-2]. Sum vertically for the total work. + ! interface [R Z3 T-3 ~> W m-2]. Sum vertically for the total work. real :: hm, fm, fr, fk ! Work variables with units of H, H, H, and H2. @@ -121,18 +122,18 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real, dimension(SZI_(G)) :: & htot, & ! The total thickness above or below a layer [H ~> m or kg m-2]. Rcv, & ! Value of the coordinate variable (potential density) - ! based on the simulated T and S and P_Ref [kg m-3]. + ! based on the simulated T and S and P_Ref [R ~> kg m-3]. pres, & ! Reference pressure (P_Ref) [Pa]. eakb, & ! The entrainment from above by the layer below the buffer ! layer (i.e. layer kb) [H ~> m or kg m-2]. ea_kbp1, & ! The entrainment from above by layer kb+1 [H ~> m or kg m-2]. eb_kmb, & ! The entrainment from below by the deepest buffer layer [H ~> m or kg m-2]. dS_kb, & ! The reference potential density difference across the - ! interface between the buffer layers and layer kb [kg m-3]. + ! interface between the buffer layers and layer kb [R ~> kg m-3]. dS_anom_lim, &! The amount by which dS_kb is reduced when limits are ! applied [kg m-3]. I_dSkbp1, & ! The inverse of the potential density difference across the - ! interface below layer kb [m3 kg-1]. + ! interface below layer kb [R-1 ~> m3 kg-1]. dtKd_kb, & ! The diapycnal diffusivity in layer kb times the time step ! [H2 ~> m2 or kg2 m-4]. maxF_correct, & ! An amount by which to correct maxF due to excessive @@ -152,7 +153,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real, dimension(SZI_(G),SZK_(G)) :: & Sref, & ! The reference potential density of the mixed and buffer layers, ! and of the two lightest interior layers (kb and kb+1) copied - ! into layers kmb+1 and kmb+2 [kg m-3]. + ! into layers kmb+1 and kmb+2 [R ~> kg m-3]. h_bl ! The thicknesses of the mixed and buffer layers, and of the two ! lightest interior layers (kb and kb+1) copied into layers kmb+1 ! and kmb+2 [H ~> m or kg m-2]. @@ -169,15 +170,15 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! 4*ds_Lay*(1/ds_k + 1/ds_k+1). [nondim] real :: dRHo ! The change in locally referenced potential density between - ! the layers above and below an interface [kg m-3]. + ! the layers above and below an interface [R ~> kg m-3]. real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors ! [m3 H-2 s-2 T-1 ~> m s-3 or m7 kg-2 s-3]. real, dimension(SZI_(G)) :: & pressure, & ! The pressure at an interface [Pa]. T_eos, S_eos, & ! The potential temperature and salinity at which to ! evaluate dRho_dT and dRho_dS [degC] and [ppt]. - dRho_dT, dRho_dS ! The partial derivatives of potential density with - ! temperature and salinity, [kg m-3 degC-1] and [kg m-3 ppt-1]. + dRho_dT, dRho_dS ! The partial derivatives of potential density with temperature and + ! salinity, [R degC-1 ~> kg m-3 degC-1] and [R ppt-1 ~> kg m-3 ppt-1]. real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. @@ -299,7 +300,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! This subroutine determines the averaged entrainment across each ! interface and causes thin and relatively light interior layers to be ! entrained by the deepest buffer layer. This also determines kb. - call set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref, h_bl) + call set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, Sref, h_bl) do i=is,ie dtKd_kb(i) = 0.0 ; if (kb(i) < nz) dtKd_kb(i) = dtKd(i,kb(i)) @@ -691,7 +692,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & .true., dS_kb, dS_anom_lim=dS_anom_lim) do k=nz-1,kb_min,-1 call calculate_density(tv%T(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state) + Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie if ((k>kb(i)) .and. (F(i,k) > 0.0)) then ! Within a time step, a layer may entrain no more than its @@ -701,7 +702,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! the layers tracked the target density better, mostly due to ! the factor of 2 error. F_cor = h(i,j,k) * MIN(1.0 , MAX(-ds_dsp1(i,k), & - (GV%Rlay(k) - Rcv(i)) / (GV%Rlay(k+1)-GV%Rlay(k))) ) + (US%kg_m3_to_R*GV%Rlay(k) - Rcv(i)) / (US%kg_m3_to_R*GV%Rlay(k+1)-US%kg_m3_to_R*GV%Rlay(k))) ) ! Ensure that (1) Entrainments are positive, (2) Corrections in ! a layer cannot deplete the layer itself (very generously), and @@ -722,7 +723,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! taking into account that the true potential density of the ! deepest buffer layer is not exactly what is returned as dS_kb. dS_kb_eff = 2.0*dS_kb(i) - dS_anom_lim(i) ! Could be negative!!! - Rho_cor = h(i,j,k) * (GV%Rlay(k)-Rcv(i)) + eakb(i)*dS_anom_lim(i) + Rho_cor = h(i,j,k) * (US%kg_m3_to_R*GV%Rlay(k)-Rcv(i)) + eakb(i)*dS_anom_lim(i) ! Ensure that -.9*eakb < ea_cor < .9*eakb if (abs(Rho_cor) < abs(0.9*eakb(i)*dS_kb_eff)) then @@ -776,14 +777,14 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & else ! not bulkmixedlayer do k=K2,nz-1 call calculate_density(tv%T(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state) + Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie ; if (F(i,k) > 0.0) then ! Within a time step, a layer may entrain no more than ! its thickness for correction. This limitation should ! apply extremely rarely, but precludes undesirable ! behavior. F_cor = h(i,j,k) * MIN(dsp1_ds(i,k) , MAX(-1.0, & - (GV%Rlay(k) - Rcv(i)) / (GV%Rlay(k+1)-GV%Rlay(k))) ) + (US%kg_m3_to_R*GV%Rlay(k) - Rcv(i)) / (US%kg_m3_to_R*GV%Rlay(k+1)-US%kg_m3_to_R*GV%Rlay(k))) ) ! Ensure that (1) Entrainments are positive, (2) Corrections in ! a layer cannot deplete the layer itself (very generously), and @@ -842,7 +843,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif enddo call calculate_density_derivs(T_eos, S_eos, pressure, & - dRho_dT, dRho_dS, is, ie-is+1, tv%eqn_of_state) + dRho_dT, dRho_dS, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie if ((k>kmb) .and. (k m or kg m-2]. real, dimension(SZI_(G),SZK_(G)), intent(out) :: Sref !< The coordinate potential density minus - !! 1000 for each layer [kg m-3]. + !! 1000 for each layer [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(G)), intent(out) :: h_bl !< The thickness of each layer [H ~> m or kg m-2]. ! This subroutine sets the average entrainment across each of the interfaces @@ -1053,13 +1055,13 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref real, dimension(SZI_(G)) :: & b1, d1, & ! Variables used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1] and [nondim]. Rcv, & ! Value of the coordinate variable (potential density) - ! based on the simulated T and S and P_Ref [kg m-3]. + ! based on the simulated T and S and P_Ref [R ~> kg m-3]. pres, & ! Reference pressure (P_Ref) [Pa]. frac_rem, & ! The fraction of the diffusion remaining [nondim]. h_interior ! The interior thickness available for entrainment [H ~> m or kg m-2]. real, dimension(SZI_(G), SZK_(G)) :: & S_est ! An estimate of the coordinate potential density - 1000 after - ! entrainment for each layer [kg m-3]. + ! entrainment for each layer [R ~> kg m-3]. real :: max_ent ! The maximum possible entrainment [H ~> m or kg m-2]. real :: dh ! An available thickness [H ~> m or kg m-2]. real :: Kd_x_dt ! The diffusion that remains after thin layers are @@ -1076,10 +1078,10 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref do i=is,ie ; pres(i) = tv%P_Ref ; enddo do k=1,kmb call calculate_density(tv%T(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state) + Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie h_bl(i,k) = h(i,j,k) + h_neglect - Sref(i,k) = Rcv(i) - 1000.0 + Sref(i,k) = Rcv(i) - CS%Rho_sig_off enddo enddo @@ -1121,7 +1123,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref do i=is,ie ; kb(i) = nz+1 ; if (do_i(i)) kb(i) = kmb+1 ; enddo do k=kmb+1,nz ; do i=is,ie ; if (do_i(i)) then - if ((k == kb(i)) .and. (S_est(i,kmb) > (GV%Rlay(k) - 1000.0))) then + if ((k == kb(i)) .and. (S_est(i,kmb) > (US%kg_m3_to_R*GV%Rlay(k) - CS%Rho_sig_off))) then if (4.0*dtKd_int(i,Kmb+1)*frac_rem(i) > & (h_bl(i,kmb) + h(i,j,k)) * (h(i,j,k) - GV%Angstrom_H)) then ! Entrain this layer into the buffer layer and move kb down. @@ -1129,7 +1131,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref if (dh > 0.0) then frac_rem(i) = frac_rem(i) - ((h_bl(i,kmb) + h(i,j,k)) * dh) / & (4.0*dtKd_int(i,Kmb+1)) - Sref(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + dh*(GV%Rlay(k)-1000.0)) / & + Sref(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + dh*(US%kg_m3_to_R*GV%Rlay(k)-CS%Rho_sig_off)) / & (h_bl(i,kmb) + dh) h_bl(i,kmb) = h_bl(i,kmb) + dh S_est(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + Ent_bl(i,Kmb)*S_est(i,kmb-1)) / & @@ -1145,16 +1147,16 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref do k=nz,kmb+1,-1 ; do i=is,ie if (k >= kb(i)) h_interior(i) = h_interior(i) + (h(i,j,k)-GV%Angstrom_H) if (k==kb(i)) then - h_bl(i,kmb+1) = h(i,j,k) ; Sref(i,kmb+1) = GV%Rlay(k) - 1000.0 + h_bl(i,kmb+1) = h(i,j,k) ; Sref(i,kmb+1) = US%kg_m3_to_R*GV%Rlay(k) - CS%Rho_sig_off elseif (k==kb(i)+1) then - h_bl(i,kmb+2) = h(i,j,k) ; Sref(i,kmb+2) = GV%Rlay(k) - 1000.0 + h_bl(i,kmb+2) = h(i,j,k) ; Sref(i,kmb+2) = US%kg_m3_to_R*GV%Rlay(k) - CS%Rho_sig_off endif enddo ; enddo do i=is,ie ; if (kb(i) >= nz) then h_bl(i,kmb+1) = h(i,j,nz) - Sref(i,kmb+1) = GV%Rlay(nz) - 1000.0 + Sref(i,kmb+1) = US%kg_m3_to_R*GV%Rlay(nz) - CS%Rho_sig_off h_bl(i,kmb+2) = GV%Angstrom_H - Sref(i,kmb+2) = Sref(i,kmb+1) + (GV%Rlay(nz) - GV%Rlay(nz-1)) + Sref(i,kmb+2) = Sref(i,kmb+1) + (US%kg_m3_to_R*GV%Rlay(nz) - US%kg_m3_to_R*GV%Rlay(nz-1)) endif ; enddo ! Perhaps we should revisit the way that the average entrainment between the @@ -1194,7 +1196,7 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. real, dimension(SZI_(G),SZK_(G)), intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< Reference potential density [kg m-3] + real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< Reference potential density [R ~> kg m-3] real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface !! around the buffer layers [H ~> m or kg m-2]. @@ -1208,18 +1210,18 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & real, dimension(SZI_(G)), intent(inout) :: dSkb !< The limited potential density !! difference across the interface !! between the bottommost buffer layer - !! and the topmost interior layer. + !! and the topmost interior layer. [R ~> kg m-3] !! dSkb > 0. real, dimension(SZI_(G)), optional, intent(inout) :: ddSkb_dE !< The partial derivative of dSkb - !! with E [kg m-3 H-1 ~> kg m-4 or m-1]. + !! with E [R H-1 ~> kg m-4 or m-1]. real, dimension(SZI_(G)), optional, intent(inout) :: dSlay !< The limited potential density !! difference across the topmost - !! interior layer. 0 < dSkb + !! interior layer. 0 < dSkb [R ~> kg m-3] real, dimension(SZI_(G)), optional, intent(inout) :: ddSlay_dE !< The partial derivative of dSlay - !! with E [kg m-3 H-1 ~> kg m-4 or m-1]. + !! with E [R H-1 ~> kg m-4 or m-1]. real, dimension(SZI_(G)), optional, intent(inout) :: dS_anom_lim !< A limiting value to use for !! the density anomalies below the - !! buffer layer [kg m-3]. + !! buffer layer [R ~> kg m-3]. logical, dimension(SZI_(G)), optional, intent(in) :: do_i_in !< If present, determines which !! columns are worked on. @@ -1242,9 +1244,9 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & ! Local variables real, dimension(SZI_(G),SZK_(G)) :: & b1, c1, & ! b1 and c1 are variables used by the tridiagonal solver. - S, dS_dE, & ! The coordinate density and its derivative with R. - ea, dea_dE, & ! The entrainment from above and its derivative with R. - eb, deb_dE ! The entrainment from below and its derivative with R. + S, dS_dE, & ! The coordinate density [R ~> kg m-3] and its derivative with E. + ea, dea_dE, & ! The entrainment from above and its derivative with E. + eb, deb_dE ! The entrainment from below and its derivative with E. real :: deriv_dSkb(SZI_(G)) real :: d1(SZI_(G)) ! d1 = 1.0-c1 is also used by the tridiagonal solver. real :: src ! A source term for dS_dR. @@ -1438,14 +1440,14 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & real, dimension(SZI_(G),SZK_(G)), & intent(in) :: Sref !< The coordinate reference potential density, !! with the value of the topmost interior layer - !! at index kmb+1 [kg m-3]. + !! at index kmb+1 [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(G)), & intent(in) :: Ent_bl !< The average entrainment upward and downward !! across each interface around the buffer layers, !! [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in reference !! potential density across the base of the - !! uppermost interior layer [m3 kg-1]. + !! uppermost interior layer [R-1 ~> m3 kg-1]. real, dimension(SZI_(G)), intent(in) :: F_kb !< The entrainment from below by the !! uppermost interior layer [H ~> m or kg m-2] integer, intent(in) :: kmb !< The number of mixed and buffer layers. @@ -1570,14 +1572,14 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< The coordinate reference potential !! density, with the value of the !! topmost interior layer at layer - !! kmb+1 [kg m-3]. + !! kmb+1 [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface around !! the buffer layers [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in !! reference potential density across !! the base of the uppermost interior - !! layer [m3 kg-1]. + !! layer [R-1 ~> m3 kg-1]. real, dimension(SZI_(G)), intent(in) :: dtKd_kb !< The diapycnal diffusivity in the top !! interior layer times the time step !! [H2 ~> m2 or kg2 m-4]. @@ -1620,10 +1622,10 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & real, dimension(SZI_(G)) :: & dS_kb, & ! The coordinate-density difference between the ! layer kb and deepest buffer layer, limited to - ! ensure that it is positive [kg m-3]. + ! ensure that it is positive [R ~> kg m-3]. dS_Lay, & ! The coordinate-density difference across layer ! kb, limited to ensure that it is positive and not - ! too much bigger than dS_kb or dS_kbp1 [kg m-3]. + ! too much bigger than dS_kb or dS_kbp1 [R ~> kg m-3]. ddSkb_dE, ddSlay_dE, & ! The derivatives of dS_kb and dS_Lay with E ! [kg m-3 H-1 ~> kg m-4 or m-1]. derror_dE, & ! The derivative of err with E [H ~> m or kg m-2]. @@ -1780,7 +1782,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & real, dimension(SZI_(G),SZK_(G)), & intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(G)), & - intent(in) :: Sref !< Reference potential density [kg m-3]. + intent(in) :: Sref !< Reference potential density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(G)), & intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface around @@ -1788,7 +1790,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in !! reference potential density across the !! base of the uppermost interior layer - !! [m3 kg-1]. + !! [R-1 ~> m3 kg-1]. real, dimension(SZI_(G)), intent(in) :: min_ent_in !< The minimum value of ent to search, !! [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: max_ent_in !< The maximum value of ent to search, @@ -1848,7 +1850,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & ! The most likely value is at max_ent. call determine_dSkb(h_bl, Sref, Ent_bl, max_ent_in, is, ie, kmb, G, GV, .false., & - dS_kb, ddSkb_dE , dS_anom_lim=dS_anom_lim) + dS_kb, ddSkb_dE, dS_anom_lim=dS_anom_lim) ie1 = is-1 ; doany = .false. do i=is,ie dS_kb_lim(i) = dS_kb(i) + dS_anom_lim(i) @@ -2125,11 +2127,13 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) "The tolerance with which to solve for entrainment values.", & units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H) + CS%Rho_sig_off = 1000.0*US%kg_m3_to_R + CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z2_T_to_m2_s) CS%id_diff_work = register_diag_field('ocean_model', 'diff_work', diag%axesTi, Time, & 'Work actually done by diapycnal diffusion across each interface', 'W m-2', & - conversion=US%Z_to_m**3*US%s_to_T**3) + conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) end subroutine entrain_diffusive_init From 57794ad966e79419c1ef429f212d84bd7d8814b5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Sep 2019 04:53:45 -0400 Subject: [PATCH 089/259] +Changed units of GV%Rlay to [R] Changed the units of GV%Rlay from [kg m-3] to [R] for dimensional consistency testing. This required the addition of unit_scale_type arguments to several interfaces. All answers are bitwise identical, but new arguments have been added to several public interfaces. --- src/ALE/MOM_regridding.F90 | 15 ++++---- src/core/MOM.F90 | 2 +- src/core/MOM_PressureForce_Montgomery.F90 | 8 ++-- src/core/MOM_PressureForce_analytic_FV.F90 | 18 ++++----- src/core/MOM_PressureForce_blocked_AFV.F90 | 18 ++++----- src/core/MOM_interface_heights.F90 | 4 +- src/core/MOM_isopycnal_slopes.F90 | 4 +- src/core/MOM_verticalGrid.F90 | 17 +++++---- src/diagnostics/MOM_diagnostics.F90 | 14 +++---- src/diagnostics/MOM_wave_speed.F90 | 8 ++-- src/diagnostics/MOM_wave_structure.F90 | 4 +- .../MOM_coord_initialization.F90 | 16 ++++++-- .../MOM_state_initialization.F90 | 27 +++++++------- .../lateral/MOM_thickness_diffuse.F90 | 4 +- .../vertical/MOM_bulk_mixed_layer.F90 | 10 ++--- .../vertical/MOM_diabatic_driver.F90 | 12 +++--- .../vertical/MOM_entrain_diffusive.F90 | 20 +++++----- .../vertical/MOM_geothermal.F90 | 26 +++++++------ .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 4 +- .../vertical/MOM_regularize_layers.F90 | 15 +++++--- .../vertical/MOM_set_diffusivity.F90 | 18 ++++----- .../vertical/MOM_set_viscosity.F90 | 24 ++++++------ src/parameterizations/vertical/MOM_sponge.F90 | 6 ++- src/tracer/MOM_tracer_hor_diff.F90 | 15 ++++---- src/user/DOME_initialization.F90 | 4 +- src/user/ISOMIP_initialization.F90 | 37 ++++++++++--------- src/user/adjustment_initialization.F90 | 6 +-- src/user/benchmark_initialization.F90 | 11 +++--- src/user/user_initialization.F90 | 2 +- 30 files changed, 198 insertions(+), 173 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index bb171aba7a..6af95c2ce4 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -311,11 +311,11 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif allocate(dz(ke)) if (ke==1) then - dz(:) = uniformResolution(ke, coord_mode, tmpReal, GV%Rlay(1), GV%Rlay(1)) + dz(:) = uniformResolution(ke, coord_mode, tmpReal, US%R_to_kg_m3*GV%Rlay(1), US%R_to_kg_m3*GV%Rlay(1)) else dz(:) = uniformResolution(ke, coord_mode, tmpReal, & - GV%Rlay(1)+0.5*(GV%Rlay(1)-GV%Rlay(2)), & - GV%Rlay(ke)+0.5*(GV%Rlay(ke)-GV%Rlay(ke-1)) ) + US%R_to_kg_m3*(GV%Rlay(1)+0.5*(GV%Rlay(1)-GV%Rlay(2))), & + US%R_to_kg_m3*(GV%Rlay(ke)+0.5*(GV%Rlay(ke)-GV%Rlay(ke-1))) ) endif if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=trim(coord_units)) @@ -491,7 +491,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! \todo This line looks like it would overwrite the target densities set just above? elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then - call set_target_densities_from_GV(GV, CS) + call set_target_densities_from_GV(GV, US, CS) call log_param(param_file, mdl, "!TARGET_DENSITIES", CS%target_density, & 'RHO target densities for interfaces', units=coordinateUnits(coord_mode)) endif @@ -1991,15 +1991,16 @@ subroutine setCoordinateResolution( dz, CS, scale ) end subroutine setCoordinateResolution !> Set target densities based on the old Rlay variable -subroutine set_target_densities_from_GV( GV, CS ) +subroutine set_target_densities_from_GV( GV, US, CS ) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(regridding_CS), intent(inout) :: CS !< Regridding control structure ! Local variables integer :: k, nz nz = CS%nk - CS%target_density(1) = GV%Rlay(1)+0.5*(GV%Rlay(1)-GV%Rlay(2)) - CS%target_density(nz+1) = GV%Rlay(nz)+0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) + CS%target_density(1) = US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) + CS%target_density(nz+1) = US%R_to_kg_m3*(GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) do k = 2,nz CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) enddo diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0e5ca00823..775a15b427 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2795,7 +2795,7 @@ subroutine extract_surface_state(CS, sfc_state) 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) else - sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) + dh * GV%Rlay(k) + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) + dh * US%R_to_kg_m3*GV%Rlay(k) endif depth(i) = depth(i) + dh enddo ; enddo diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 9bb0a02606..ebcc3e4afc 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -150,7 +150,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb I_gEarth = 1.0 / (US%L_T_to_m_s**2 * GV%g_Earth) dp_neglect = GV%H_to_Pa * GV%H_subroundoff - do k=1,nz ; alpha_Lay(k) = 1.0 / GV%Rlay(k) ; enddo + do k=1,nz ; alpha_Lay(k) = 1.0 / (US%R_to_kg_m3*GV%Rlay(k)) ; enddo do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo if (use_p_atm) then @@ -235,7 +235,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (GV%Rlay(k) < Rho_cv_BL(i)) then + if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -491,7 +491,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (GV%Rlay(k) < Rho_cv_BL(i)) then + if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -745,7 +745,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) dP_dH = US%m_s_to_L_T**2*GV%H_to_Pa dp_neglect = GV%H_to_Pa * GV%H_subroundoff - do k=1,nz ; alpha_Lay(k) = 1.0 / GV%Rlay(k) ; enddo + do k=1,nz ; alpha_Lay(k) = 1.0 / (US%R_to_kg_m3*GV%Rlay(k)) ; enddo do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo if (use_EOS) then diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index f84b8e780e..0d56722825 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -231,7 +231,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (GV%Rlay(k) < Rho_cv_BL(i)) then + if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -286,7 +286,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p useMassWghtInterp = CS%useMassWghtInterp) endif else - alpha_anom = 1.0/GV%Rlay(k) - alpha_ref + alpha_anom = 1.0/(US%R_to_kg_m3*GV%Rlay(k)) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dp(i,j) = GV%H_to_Pa * h(i,j,k) dza(i,j,k) = alpha_anom * dp(i,j) @@ -349,7 +349,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * US%m_s_to_L_T**2 * & - (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) + (p(i,j,1)*(1.0/(US%R_to_kg_m3*GV%Rlay(1)) - alpha_ref) + za(i,j)) enddo ; enddo endif ! else @@ -590,7 +590,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (GV%Rlay(k) < Rho_cv_BL(i)) then + if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -622,7 +622,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * e(i,j,1) + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * US%R_to_kg_m3*GV%Rlay(1)) * e(i,j,1) enddo ; enddo endif endif @@ -702,16 +702,16 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz(i,j) = g_Earth_z * GV%H_to_Z*h(i,j,k) - dpa(i,j) = (GV%Rlay(k) - rho_ref)*dz(i,j) - intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref)*dz(i,j)*h(i,j,k) + dpa(i,j) = (US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz(i,j) + intz_dpa(i,j) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz(i,j)*h(i,j,k) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i+1,j)) + intx_dpa(I,j) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i+1,j)) enddo ; enddo !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i,j+1)) + inty_dpa(i,J) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i,j+1)) enddo ; enddo endif diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 773bcefc1d..87b325ef15 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -227,7 +227,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (GV%Rlay(k) < Rho_cv_BL(i)) then + if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -251,7 +251,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & useMassWghtInterp = CS%useMassWghtInterp) else - alpha_anom = 1.0/GV%Rlay(k) - alpha_ref + alpha_anom = 1.0/(US%R_to_kg_m3*GV%Rlay(k)) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dp(i,j) = GV%H_to_Pa * h(i,j,k) dza(i,j,k) = alpha_anom * dp(i,j) @@ -314,7 +314,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * & - US%m_s_to_L_T**2*(p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) + US%m_s_to_L_T**2*(p(i,j,1)*(1.0/(US%R_to_kg_m3*GV%Rlay(1)) - alpha_ref) + za(i,j)) enddo ; enddo endif ! else @@ -574,7 +574,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (GV%Rlay(k) < Rho_cv_BL(i)) then + if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -606,7 +606,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * e(i,j,1) + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * US%R_to_kg_m3*GV%Rlay(1)) * e(i,j,1) enddo ; enddo endif endif @@ -698,14 +698,14 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 i = ib+ioff_bk ; j = jb+joff_bk dz_bk(ib,jb) = g_Earth_z*GV%H_to_Z*h(i,j,k) - dpa_bk(ib,jb) = (GV%Rlay(k) - rho_ref)*dz_bk(ib,jb) - intz_dpa_bk(ib,jb) = 0.5*(GV%Rlay(k) - rho_ref)*dz_bk(ib,jb)*h(i,j,k) + dpa_bk(ib,jb) = (US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz_bk(ib,jb) + intz_dpa_bk(ib,jb) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz_bk(ib,jb)*h(i,j,k) enddo ; enddo do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - intx_dpa_bk(Ib,jb) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib+1,jb)) + intx_dpa_bk(Ib,jb) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib+1,jb)) enddo ; enddo do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - inty_dpa_bk(ib,Jb) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib,jb+1)) + inty_dpa_bk(ib,Jb) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib,jb+1)) enddo ; enddo endif diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 7d12f0b9e9..538e354133 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -116,7 +116,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) else !$OMP do do j=jsv,jev ; do k=nz,1,-1; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + H_to_rho_eta*h(i,j,k)/GV%Rlay(k) + eta(i,j,K) = eta(i,j,K+1) + H_to_rho_eta*h(i,j,k) / (US%R_to_kg_m3*GV%Rlay(k)) enddo ; enddo ; enddo endif if (present(eta_bt)) then @@ -214,7 +214,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) else !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + H_to_rho_eta*h(i,j,k)/GV%Rlay(k) + eta(i,j) = eta(i,j) + H_to_rho_eta*h(i,j,k) / (US%R_to_kg_m3*GV%Rlay(k)) enddo ; enddo ; enddo endif if (present(eta_bt)) then diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 30a2a451a8..61118074fd 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -166,7 +166,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 - drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) + drdkL = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) ; drdkR = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) endif ! Calculate the zonal isopycnal slope. @@ -253,7 +253,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 - drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) + drdkL = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) ; drdkR = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) endif if (use_EOS) then diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 09807e6175..2d313c5148 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -49,7 +49,7 @@ module MOM_verticalGrid !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. real, allocatable, dimension(:) :: & g_prime, & !< The reduced gravity at each interface [L2 Z-1 T-2 ~> m s-2]. - Rlay !< The target coordinate value (potential density) in each layer [kg m-3]. + Rlay !< The target coordinate value (potential density) in each layer [R ~> kg m-3]. integer :: nkml = 0 !< The number of layers at the top that should be treated !! as parts of a homogeneous region. integer :: nk_rho_varies = 0 !< The number of layers at the top where the @@ -272,9 +272,10 @@ function get_tr_flux_units(GV, tr_units, tr_vol_conc_units, tr_mass_conc_units) end function get_tr_flux_units !> This sets the coordinate data for the "layer mode" of the isopycnal model. -subroutine setVerticalGridAxes( Rlay, GV ) +subroutine setVerticalGridAxes( Rlay, GV, scale ) type(verticalGrid_type), intent(inout) :: GV !< The container for vertical grid data - real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density + real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density [R ~> kg m-3] + real, intent(in) :: scale !< A unit scaling factor for Rlay ! Local variables integer :: k, nk @@ -282,13 +283,13 @@ subroutine setVerticalGridAxes( Rlay, GV ) GV%zAxisLongName = 'Target Potential Density' GV%zAxisUnits = 'kg m-3' - do k=1,nk ; GV%sLayer(k) = Rlay(k) ; enddo + do k=1,nk ; GV%sLayer(k) = scale*Rlay(k) ; enddo if (nk > 1) then - GV%sInterface(1) = 1.5*Rlay(1) - 0.5*Rlay(2) - do K=2,nk ; GV%sInterface(K) = 0.5*( Rlay(k-1) + Rlay(k) ) ; enddo - GV%sInterface(nk+1) = 1.5*Rlay(nk) - 0.5*Rlay(nk-1) + GV%sInterface(1) = scale * (1.5*Rlay(1) - 0.5*Rlay(2)) + do K=2,nk ; GV%sInterface(K) = scale * 0.5*( Rlay(k-1) + Rlay(k) ) ; enddo + GV%sInterface(nk+1) = scale * (1.5*Rlay(nk) - 0.5*Rlay(nk-1)) else - GV%sInterface(1) = 0.0 ; GV%sInterface(nk+1) = 2.0*Rlay(nk) + GV%sInterface(1) = 0.0 ; GV%sInterface(nk+1) = 2.0*scale*Rlay(nk) endif end subroutine setVerticalGridAxes diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8fa106c4e0..1d9e7f39b7 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -471,7 +471,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - Rcv(i,j,k) = GV%Rlay(k) + Rcv(i,j,k) = US%R_to_kg_m3*GV%Rlay(k) enddo ; enddo ; enddo endif if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rcv, CS%diag) @@ -489,7 +489,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%h_Rlay(i,j,k) = h(i,j,k) enddo ; enddo do k=1,nkmb ; do i=is,ie - call find_weights(GV%Rlay, Rcv(i,j,k), k_list, nz, wt, wt_p) + call find_weights(US%R_to_kg_m3*GV%Rlay, Rcv(i,j,k), k_list, nz, wt, wt_p) CS%h_Rlay(i,j,k_list) = CS%h_Rlay(i,j,k_list) + h(i,j,k)*wt CS%h_Rlay(i,j,k_list+1) = CS%h_Rlay(i,j,k_list+1) + h(i,j,k)*wt_p enddo ; enddo @@ -511,7 +511,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ; enddo k_list = nz/2 do k=1,nkmb ; do I=Isq,Ieq - call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) + call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) CS%uh_Rlay(I,j,k_list) = CS%uh_Rlay(I,j,k_list) + uh(I,j,k)*wt CS%uh_Rlay(I,j,k_list+1) = CS%uh_Rlay(I,j,k_list+1) + uh(I,j,k)*wt_p enddo ; enddo @@ -532,7 +532,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%vh_Rlay(i,J,k) = vh(i,J,k) enddo ; enddo do k=1,nkmb ; do i=is,ie - call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) + call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) CS%vh_Rlay(i,J,k_list) = CS%vh_Rlay(i,J,k_list) + vh(i,J,k)*wt CS%vh_Rlay(i,J,k_list+1) = CS%vh_Rlay(i,J,k_list+1) + vh(i,J,k)*wt_p enddo ; enddo @@ -553,7 +553,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%uhGM_Rlay(I,j,k) = CDp%uhGM(I,j,k) enddo ; enddo do k=1,nkmb ; do I=Isq,Ieq - call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) + call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) CS%uhGM_Rlay(I,j,k_list) = CS%uhGM_Rlay(I,j,k_list) + CDp%uhGM(I,j,k)*wt CS%uhGM_Rlay(I,j,k_list+1) = CS%uhGM_Rlay(I,j,k_list+1) + CDp%uhGM(I,j,k)*wt_p enddo ; enddo @@ -574,7 +574,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%vhGM_Rlay(i,J,k) = CDp%vhGM(i,J,k) enddo ; enddo do k=1,nkmb ; do i=is,ie - call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) + call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) CS%vhGM_Rlay(i,J,k_list) = CS%vhGM_Rlay(i,J,k_list) + CDp%vhGM(i,J,k)*wt CS%vhGM_Rlay(i,J,k_list+1) = CS%vhGM_Rlay(i,J,k_list+1) + CDp%vhGM(i,J,k)*wt_p enddo ; enddo @@ -850,7 +850,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) enddo else do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + (GV%H_to_m*GV%Rlay(k))*h(i,j,k) + mass(i,j) = mass(i,j) + (GV%H_to_m*US%R_to_kg_m3*GV%Rlay(k))*h(i,j,k) enddo ; enddo ; enddo endif else diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index f8fc9b7cf9..cd9dd9dbb8 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -192,10 +192,10 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! Start a new layer H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) else H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -649,10 +649,10 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Start a new layer H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) else H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index ac28a8d012..d8c7cc5a02 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -229,10 +229,10 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Start a new layer H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) else H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index fd77676008..bd7fcccb0c 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -84,30 +84,40 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept select case ( trim(config) ) case ("gprime") call set_coord_from_gprime(GV%Rlay, GV%g_prime, GV, US, PF) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("layer_ref") call set_coord_from_layer_density(GV%Rlay, GV%g_prime, GV, US, PF) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("linear") call set_coord_linear(GV%Rlay, GV%g_prime, GV, US, PF) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("ts_ref") call set_coord_from_ts_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("ts_profile") call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("ts_range") call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("file") call set_coord_from_file(GV%Rlay, GV%g_prime, GV, US, PF) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("USER") call user_set_coord(GV%Rlay, GV%g_prime, GV, PF, eos) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("BFB") call BFB_set_coord(GV%Rlay, GV%g_prime, GV, PF, eos) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("none", "ALE") call set_coord_to_none(GV%Rlay, GV%g_prime, GV, US, PF) + GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case default ; call MOM_error(FATAL,"MOM_initialize_coord: "// & "Unrecognized coordinate setup"//trim(config)) end select - if (debug) call chksum(GV%Rlay, "MOM_initialize_coord: Rlay ", 1, nz) + if (debug) call chksum(US%R_to_kg_m3*GV%Rlay(:), "MOM_initialize_coord: Rlay ", 1, nz) if (debug) call chksum(US%m_to_Z*US%L_to_m**2*US%s_to_T**2*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) - call setVerticalGridAxes( GV%Rlay, GV ) + call setVerticalGridAxes( GV%Rlay, GV, scale=US%R_to_kg_m3 ) ! Copy the maximum depth across from the input argument GV%max_depth = max_depth @@ -525,7 +535,7 @@ subroutine write_vertgrid_file(GV, US, param_file, directory) call create_file(unit, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) - call write_field(unit, fields(1), GV%Rlay) + call write_field(unit, fields(1), US%R_to_kg_m3*GV%Rlay(:)) call write_field(unit, fields(2), US%L_T_to_m_s**2*US%m_to_Z*GV%g_prime(:)) call close_file(unit) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 1f5401ee58..9210da72da 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -351,12 +351,12 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & fail_if_missing=new_sim, do_not_log=just_read) ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& select case (trim(config)) - case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, PF, & + case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, US, PF, & eos, tv%P_Ref, just_read_params=just_read) case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, & PF, just_read_params=just_read) case ("benchmark"); call benchmark_init_temperature_salinity(tv%T, tv%S, & - G, GV, PF, eos, tv%P_Ref, just_read_params=just_read) + G, GV, US, PF, eos, tv%P_Ref, just_read_params=just_read) case ("TS_profile") ; call initialize_temp_salt_from_profile(tv%T, tv%S, & G, PF, just_read_params=just_read) case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, PF, & @@ -364,7 +364,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("DOME2D"); call DOME2d_initialize_temperature_salinity ( tv%T, & 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) + tv%S, h, G, GV, US, PF, eos, just_read_params=just_read) case ("adjustment2d"); call adjustment_initialize_temperature_salinity ( tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("baroclinic_zone"); call baroclinic_zone_init_temperature_salinity( tv%T, & @@ -993,9 +993,9 @@ subroutine convert_thickness(h, G, GV, US, 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)) * Hm_rho_to_Pa * GV%kg_m2_to_H**2 + h(i,j,k) = (h(i,j,k) * US%R_to_kg_m3*GV%Rlay(k)) * Hm_rho_to_Pa * GV%kg_m2_to_H**2 ! This is mathematically equivalent to - ! h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) + ! h(i,j,k) = h(i,j,k) * (US%R_to_kg_m3*GV%Rlay(k) / GV%Rho0) enddo ; enddo ; enddo endif endif @@ -1530,13 +1530,14 @@ subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_para end subroutine initialize_temp_salt_from_profile !> Initializes temperature and salinity by fitting to density -subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref, just_read_params) +subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P_Ref, 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_(G)), intent(out) :: T !< The potential temperature that is !! being initialized [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being !! initialized [ppt]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(EOS_type), pointer :: eqn_of_state !< Integer that selects the equatio of state. @@ -1587,26 +1588,26 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref if (fit_salin) then ! A first guess of the layers' temperatures. do k=nz,1,-1 - S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS(1)) + S0(k) = max(0.0, S0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dS(1)) enddo ! Refine the guesses for each layer. do itt=1,6 call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) do k=1,nz - S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) + S0(k) = max(0.0, S0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) enddo enddo else ! A first guess of the layers' temperatures. do k=nz,1,-1 - T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) + T0(k) = T0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dT(1) enddo do itt=1,6 call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) do k=1,nz - T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo endif @@ -2284,8 +2285,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! Rb contains the layer interface densities allocate(Rb(nz+1)) - do k=2,nz ; Rb(k)=0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo - Rb(1) = 0.0 ; Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) + do k=2,nz ; Rb(k) = 0.5*US%R_to_kg_m3*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo + Rb(1) = 0.0 ; Rb(nz+1) = US%R_to_kg_m3*( 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) ) zi(is:ie,js:je,:) = find_interfaces(rho_z(is:ie,js:je,:), z_in, Rb, G%bathyT(is:ie,js:je), & nlevs(is:ie,js:je), nkml, nkbl, min_depth, eps_z=eps_z) @@ -2359,7 +2360,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (adjust_temperature .and. .not. useALEremapping) then call determine_temperature(tv%T(is:ie,js:je,:), tv%S(is:ie,js:je,:), & - GV%Rlay(1:nz), tv%p_ref, niter, missing_value, h(is:ie,js:je,:), ks, eos) + US%R_to_kg_m3*GV%Rlay(1:nz), tv%p_ref, niter, missing_value, h(is:ie,js:je,:), ks, eos) endif diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 2b4cdfadee..dc235a369e 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -732,7 +732,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 - drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = drdkL + drdkL = US%R_to_kg_m3*(GV%Rlay(k) - GV%Rlay(k-1)) ; drdkR = drdkL endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & @@ -984,7 +984,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 - drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = drdkL + drdkL = US%R_to_kg_m3*(GV%Rlay(k) - GV%Rlay(k-1)) ; drdkR = drdkL endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 5eaff15866..1dfb1c36e4 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -606,7 +606,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, if (CS%ML_resort) then if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) - call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), US%kg_m3_to_R*GV%Rlay(:), eps, & + call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) endif @@ -642,11 +642,11 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, if (id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) if (CS%nkbl == 1) then call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & - US%kg_m3_to_R*GV%Rlay(:), dt_in_T, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & + GV%Rlay(:), dt_in_T, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & dRcv_dT, dRcv_dS, max_BL_det) elseif (CS%nkbl == 2) then call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & - US%kg_m3_to_R*GV%Rlay(:), dt_in_T, dt__diag, d_ea, j, G, GV, US, CS, & + GV%Rlay(:), dt_in_T, dt__diag, d_ea, j, G, GV, US, CS, & dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) else ! CS%nkbl not = 1 or 2 ! This code only works with 1 or 2 buffer layers. @@ -2330,7 +2330,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real :: dT_dS_gauge, dS_dT_gauge ! The relative scales of temperature and ! salinity changes in defining spiciness, in ! [degC ppt-1] and [ppt degC-1]. - real :: I_denom ! A work variable with units of [ppt2 m6 kg-2]. + real :: I_denom ! A work variable with units of [ppt2 R-2 ~> ppt2 m6 kg-2]. real :: g_2 ! 1/2 g_Earth [L2 Z-1 T-2 ~> m s-2]. real :: Rho0xG ! Rho0 times G_Earth [R L2 Z-1 T-2 ~> kg m-2 s-2]. @@ -3143,7 +3143,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea real :: detrain(SZI_(G)) ! The thickness of fluid to detrain ! from the mixed layer [H ~> m or kg m-2]. real :: dT_dR, dS_dR, dRml, dR0_dRcv, dT_dS_wt2 - real :: I_denom ! A work variable [ppt2 m6 kg-2]. + real :: I_denom ! A work variable [ppt2 R-2 ~> ppt2 m6 kg-2]. real :: Sdown, Tdown real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the square of the diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 369ee5da40..728a2b2fa6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -573,7 +573,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal(h, tv, dt, eatr, ebtr, G, GV, CS%geothermal_CSp, halo=CS%halo_TS_diff) + call geothermal(h, tv, dt, eatr, ebtr, G, GV, US, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) @@ -1358,7 +1358,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal(h, tv, dt, eatr, ebtr, G, GV, CS%geothermal_CSp, halo=CS%halo_TS_diff) + call geothermal(h, tv, dt, eatr, ebtr, G, GV, US, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) @@ -2049,7 +2049,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp, halo=CS%halo_TS_diff) + call geothermal(h, tv, dt, eaml, ebml, G, GV, US, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) @@ -2555,7 +2555,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e endif call cpu_clock_begin(id_clock_remap) - call regularize_layers(h, tv, dt, ea, eb, G, GV, CS%regularize_layers_CSp) + call regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS%regularize_layers_CSp) call cpu_clock_end(id_clock_remap) if (showCallTree) call callTree_waypoint("done with regularize_layers (diabatic)") if (CS%debugConservation) call MOM_state_stats('regularize_layers', u, v, h, tv%T, tv%S, G, GV, US) @@ -2689,9 +2689,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & is, ie-is+1, tv%eqn_of_state) enddo - call apply_sponge(h, dt, G, GV, ea, eb, CS%sponge_CSp, Rcv_ml) + call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else - call apply_sponge(h, dt, G, GV, ea, eb, CS%sponge_CSp) + call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp) endif call cpu_clock_end(id_clock_sponge) if (CS%debug) then diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index baebe570e4..967dd31ae9 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -702,7 +702,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! the layers tracked the target density better, mostly due to ! the factor of 2 error. F_cor = h(i,j,k) * MIN(1.0 , MAX(-ds_dsp1(i,k), & - (US%kg_m3_to_R*GV%Rlay(k) - Rcv(i)) / (US%kg_m3_to_R*GV%Rlay(k+1)-US%kg_m3_to_R*GV%Rlay(k))) ) + (GV%Rlay(k) - Rcv(i)) / (GV%Rlay(k+1)-GV%Rlay(k))) ) ! Ensure that (1) Entrainments are positive, (2) Corrections in ! a layer cannot deplete the layer itself (very generously), and @@ -723,7 +723,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! taking into account that the true potential density of the ! deepest buffer layer is not exactly what is returned as dS_kb. dS_kb_eff = 2.0*dS_kb(i) - dS_anom_lim(i) ! Could be negative!!! - Rho_cor = h(i,j,k) * (US%kg_m3_to_R*GV%Rlay(k)-Rcv(i)) + eakb(i)*dS_anom_lim(i) + Rho_cor = h(i,j,k) * (GV%Rlay(k)-Rcv(i)) + eakb(i)*dS_anom_lim(i) ! Ensure that -.9*eakb < ea_cor < .9*eakb if (abs(Rho_cor) < abs(0.9*eakb(i)*dS_kb_eff)) then @@ -784,7 +784,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! apply extremely rarely, but precludes undesirable ! behavior. F_cor = h(i,j,k) * MIN(dsp1_ds(i,k) , MAX(-1.0, & - (US%kg_m3_to_R*GV%Rlay(k) - Rcv(i)) / (US%kg_m3_to_R*GV%Rlay(k+1)-US%kg_m3_to_R*GV%Rlay(k))) ) + (GV%Rlay(k) - Rcv(i)) / (GV%Rlay(k+1)-GV%Rlay(k))) ) ! Ensure that (1) Entrainments are positive, (2) Corrections in ! a layer cannot deplete the layer itself (very generously), and @@ -862,7 +862,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo else do K=2,nz ; do i=is,ie - diff_work(i,j,K) = g_2dt * (US%kg_m3_to_R*GV%Rlay(k)-US%kg_m3_to_R*GV%Rlay(k-1)) * & + diff_work(i,j,K) = g_2dt * (GV%Rlay(k)-GV%Rlay(k-1)) * & (ea(i,j,k) * (h(i,j,k) + ea(i,j,k)) + & eb(i,j,k-1)*(h(i,j,k-1) + eb(i,j,k-1))) enddo ; enddo @@ -1123,7 +1123,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, do i=is,ie ; kb(i) = nz+1 ; if (do_i(i)) kb(i) = kmb+1 ; enddo do k=kmb+1,nz ; do i=is,ie ; if (do_i(i)) then - if ((k == kb(i)) .and. (S_est(i,kmb) > (US%kg_m3_to_R*GV%Rlay(k) - CS%Rho_sig_off))) then + if ((k == kb(i)) .and. (S_est(i,kmb) > (GV%Rlay(k) - CS%Rho_sig_off))) then if (4.0*dtKd_int(i,Kmb+1)*frac_rem(i) > & (h_bl(i,kmb) + h(i,j,k)) * (h(i,j,k) - GV%Angstrom_H)) then ! Entrain this layer into the buffer layer and move kb down. @@ -1131,7 +1131,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, if (dh > 0.0) then frac_rem(i) = frac_rem(i) - ((h_bl(i,kmb) + h(i,j,k)) * dh) / & (4.0*dtKd_int(i,Kmb+1)) - Sref(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + dh*(US%kg_m3_to_R*GV%Rlay(k)-CS%Rho_sig_off)) / & + Sref(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + dh*(GV%Rlay(k)-CS%Rho_sig_off)) / & (h_bl(i,kmb) + dh) h_bl(i,kmb) = h_bl(i,kmb) + dh S_est(i,kmb) = (h_bl(i,kmb)*Sref(i,kmb) + Ent_bl(i,Kmb)*S_est(i,kmb-1)) / & @@ -1147,16 +1147,16 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, do k=nz,kmb+1,-1 ; do i=is,ie if (k >= kb(i)) h_interior(i) = h_interior(i) + (h(i,j,k)-GV%Angstrom_H) if (k==kb(i)) then - h_bl(i,kmb+1) = h(i,j,k) ; Sref(i,kmb+1) = US%kg_m3_to_R*GV%Rlay(k) - CS%Rho_sig_off + h_bl(i,kmb+1) = h(i,j,k) ; Sref(i,kmb+1) = GV%Rlay(k) - CS%Rho_sig_off elseif (k==kb(i)+1) then - h_bl(i,kmb+2) = h(i,j,k) ; Sref(i,kmb+2) = US%kg_m3_to_R*GV%Rlay(k) - CS%Rho_sig_off + h_bl(i,kmb+2) = h(i,j,k) ; Sref(i,kmb+2) = GV%Rlay(k) - CS%Rho_sig_off endif enddo ; enddo do i=is,ie ; if (kb(i) >= nz) then h_bl(i,kmb+1) = h(i,j,nz) - Sref(i,kmb+1) = US%kg_m3_to_R*GV%Rlay(nz) - CS%Rho_sig_off + Sref(i,kmb+1) = GV%Rlay(nz) - CS%Rho_sig_off h_bl(i,kmb+2) = GV%Angstrom_H - Sref(i,kmb+2) = Sref(i,kmb+1) + (US%kg_m3_to_R*GV%Rlay(nz) - US%kg_m3_to_R*GV%Rlay(nz-1)) + Sref(i,kmb+2) = Sref(i,kmb+1) + (GV%Rlay(nz) - GV%Rlay(nz-1)) endif ; enddo ! Perhaps we should revisit the way that the average entrainment between the diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 5fefbf199e..bac7a20313 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -5,14 +5,15 @@ module MOM_geothermal use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : register_static_field, time_type, diag_ctrl -use MOM_domains, only : pass_var +use MOM_domains, only : pass_var 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_io, only : MOM_read_data, slasher -use MOM_grid, only : ocean_grid_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_io, only : MOM_read_data, slasher +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_EOS, only : calculate_density, calculate_density_derivs implicit none ; private @@ -49,7 +50,7 @@ module MOM_geothermal !! the partial derivative of the coordinate density with temperature is positive !! or very small, the layers are simply heated in place. Any heat that can not !! be applied to the ocean is returned (WHERE)? -subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) +subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -66,6 +67,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) !! into a layer; this should be !! increased due to mixed layer !! entrainment [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(geothermal_CS), pointer :: CS !< The control structure returned by !! a previous call to !! geothermal_init. @@ -227,14 +229,14 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) ! Simply heat the layer; convective adjustment occurs later ! if necessary. k_tgt = k - elseif ((k==nkmb+1) .or. (GV%Rlay(k-1) < Rcv_BL(i))) then + elseif ((k==nkmb+1) .or. (US%R_to_kg_m3*GV%Rlay(k-1) < Rcv_BL(i))) then ! Add enough heat to match the lowest buffer layer density. k_tgt = nkmb Rcv_tgt = Rcv_BL(i) else ! Add enough heat to match the target density of layer k-1. k_tgt = k-1 - Rcv_tgt = GV%Rlay(k-1) + Rcv_tgt = US%R_to_kg_m3*GV%Rlay(k-1) endif if (k<=nkmb .or. nkmb<=0) then @@ -256,13 +258,13 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) elseif (dRcv_dT <= CS%dRcv_dT_inplace) then ! This is the option that usually applies in isopycnal coordinates. heat_in_place = min(heat_avail, max(0.0, h(i,j,k) * & - ((GV%Rlay(k)-Rcv) / dRcv_dT))) + ((US%R_to_kg_m3*GV%Rlay(k)-Rcv) / dRcv_dT))) heat_trans = heat_avail - heat_in_place else ! wt_in_place should go from 0 to 1. wt_in_place = (CS%dRcv_dT_inplace - dRcv_dT) / CS%dRcv_dT_inplace heat_in_place = max(wt_in_place*heat_avail, & - h(i,j,k) * ((GV%Rlay(k)-Rcv) / dRcv_dT) ) + h(i,j,k) * ((US%R_to_kg_m3*GV%Rlay(k)-Rcv) / dRcv_dT) ) heat_trans = heat_avail - heat_in_place endif diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 79c1b744f0..5a9b9b5bbd 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -219,7 +219,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) enddo else do K=2,nz ; do i=is,ie - dRho_int(i,K) = GV%Rlay(k) - GV%Rlay(k-1) + dRho_int(i,K) = US%R_to_kg_m3*(GV%Rlay(k) - GV%Rlay(k-1)) enddo ; enddo endif diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index f5343f86e2..437c52bd6d 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -194,7 +194,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & if (use_temperature) then ; do k=1,nz ; do i=is,ie T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) enddo ; enddo ; else ; do k=1,nz ; do i=is,ie - rho_2d(i,k) = GV%Rlay(k) ! Could be tv%Rho(i,j,k) ? + rho_2d(i,k) = US%R_to_kg_m3*GV%Rlay(k) ! Could be tv%Rho(i,j,k) ? enddo ; enddo ; endif if (.not.new_kappa) then ; do K=1,nz+1 ; do i=is,ie kappa_2d(i,K) = kappa_io(i,j,K) @@ -492,7 +492,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ! (h(i+1,j,k)**2 + h(i,j+1,k)**2))*GV%H_to_Z * I_hwt enddo ; enddo if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB - rho_2d(I,k) = GV%Rlay(k) + rho_2d(I,k) = US%R_to_kg_m3*GV%Rlay(k) enddo ; enddo ; endif if (.not.new_kappa) then ; do K=1,nz+1 ; do I=IsB,IeB kappa_2d(I,K,J2) = kv_io(I,J,K) * I_Prandtl diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index cca2d9f94e..541302a7c9 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -10,6 +10,7 @@ module MOM_regularize_layers use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -74,7 +75,7 @@ module MOM_regularize_layers !> This subroutine partially steps the bulk mixed layer model. !! The following processes are executed, in the order listed. -subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, CS) +subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, 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(SZI_(G),SZJ_(G),SZK_(G)), & @@ -91,6 +92,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, CS) intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer !! entrainment [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(regularize_layers_CS), pointer :: CS !< The control structure returned by a previous !! call to regularize_layers_init. ! Local variables @@ -105,14 +107,14 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, CS) call pass_var(h, G%Domain, clock=id_clock_pass) if (CS%regularize_surface_layers) then - call regularize_surface(h, tv, dt, ea, eb, G, GV, CS) + call regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) endif end subroutine regularize_layers !> This subroutine ensures that there is a degree of horizontal smoothness !! in the depths of the near-surface interfaces. -subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) +subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, 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(SZI_(G),SZJ_(G),SZK_(G)), & @@ -129,6 +131,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer !! entrainment [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(regularize_layers_CS), pointer :: CS !< The control structure returned by a previous !! call to regularize_layers_init. ! Local variables @@ -452,11 +455,11 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) if (k1 <= 1) exit if (k2 <= nkmb) exit ! ### The 0.6 here should be adjustable? It gives 20% overlap for now. - Rcv_min_det = GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2-1)-GV%Rlay(k2)) + Rcv_min_det = US%R_to_kg_m3*(GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2-1)-GV%Rlay(k2))) if (k2 < nz) then - Rcv_max_det = GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2+1)-GV%Rlay(k2)) + Rcv_max_det = US%R_to_kg_m3*(GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2+1)-GV%Rlay(k2))) else - Rcv_max_det = GV%Rlay(nz) + 0.6*Rcv_tol(i)*(GV%Rlay(nz)-GV%Rlay(nz-1)) + Rcv_max_det = US%R_to_kg_m3*(GV%Rlay(nz) + 0.6*Rcv_tol(i)*(GV%Rlay(nz)-GV%Rlay(nz-1))) endif if (Rcv(i,k1) > Rcv_max_det) & exit ! All shallower interior layers are too light for detrainment. diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 7d118bc00a..9a73801b1b 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -728,7 +728,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie ! Determine the next denser layer than the buffer layer in the ! coordinate density (sigma-2). - do k=kmb+1,nz-1 ; if (Rcv_kmb(i) <= GV%Rlay(k)) exit ; enddo + do k=kmb+1,nz-1 ; if (Rcv_kmb(i) <= US%R_to_kg_m3*GV%Rlay(k)) exit ; enddo kb(i) = k ! Backtrack, in case there are massive layers above that are stable @@ -921,7 +921,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo else do K=2,nz ; do i=is,ie - dRho_int(i,K) = GV%Rlay(k) - GV%Rlay(k-1) + dRho_int(i,K) = US%R_to_kg_m3*GV%Rlay(k) - US%R_to_kg_m3*GV%Rlay(k-1) enddo ; enddo endif @@ -1180,7 +1180,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & I_Rho0 = 1.0/GV%Rho0 R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) - do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo + do K=2,nz ; Rint(K) = 0.5*(US%R_to_kg_m3*GV%Rlay(k-1)+US%R_to_kg_m3*GV%Rlay(k)) ; enddo kb_min = max(GV%nk_rho_varies+1,2) @@ -1216,16 +1216,16 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & do_i(i) = (G%mask2dT(i,j) > 0.5) htot(i) = GV%H_to_Z*h(i,j,nz) - rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) - Rho_top(i) = GV%Rlay(1) - if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = GV%Rlay(kb(i)-1) + rho_htot(i) = US%R_to_kg_m3*GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) + Rho_top(i) = US%R_to_kg_m3*GV%Rlay(1) + if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = US%R_to_kg_m3*GV%Rlay(kb(i)-1) enddo do k=nz-1,2,-1 ; domore = .false. do i=is,ie ; if (do_i(i)) then htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) - if (htot(i)*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then + rho_htot(i) = rho_htot(i) + US%R_to_kg_m3*GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) + if (htot(i)*US%R_to_kg_m3*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then ! The top of the mixing is in the interface atop the current layer. Rho_top(i) = (rho_htot(i) - gh_sum_top(i)) / htot(i) do_i(i) = .false. @@ -1835,7 +1835,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) I_Drho = g_R0 / GV%g_prime(k+1) ! The indexing convention for a is appropriate for the interfaces. do k3=1,kmb - a(k3+1) = (GV%Rlay(k) - Rcv(i,k3)) * I_Drho + a(k3+1) = (US%R_to_kg_m3*GV%Rlay(k) - Rcv(i,k3)) * I_Drho enddo if ((present(rho_0)) .and. (a(kmb+1) < 2.0*eps*ds_dsp1(i,k))) then ! If the buffer layer nearly matches the density of the layer below in the diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 30648c7d61..02b5c9691d 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -589,8 +589,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) else ! Use Rlay and/or the coordinate density as density variables. Rhtot = 0.0 do k=nz,K2,-1 - oldfn = Rhtot - GV%Rlay(k)*htot - Dfn = (GV%Rlay(k) - GV%Rlay(k-1))*(h_at_vel(i,k)+htot) + oldfn = Rhtot - US%R_to_kg_m3*GV%Rlay(k)*htot + Dfn = (US%R_to_kg_m3*GV%Rlay(k) - US%R_to_kg_m3*GV%Rlay(k-1))*(h_at_vel(i,k)+htot) if (oldfn >= ustarsq) then cycle @@ -601,7 +601,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) endif htot = htot + Dh - Rhtot = Rhtot + GV%Rlay(k)*Dh + Rhtot = Rhtot + US%R_to_kg_m3*GV%Rlay(k)*Dh enddo if (nkml>0) then do k=nkmb,2,-1 @@ -621,7 +621,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) enddo if (Rhtot - Rml_vel(i,1)*htot < ustarsq) htot = htot + h_at_vel(i,1) else - if (Rhtot - GV%Rlay(1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - US%R_to_kg_m3*GV%Rlay(1)*htot < ustarsq) htot = htot + h_at_vel(i,1) endif endif ! use_BBL_EOS @@ -1250,7 +1250,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & dR_dS(I) * (S_lay*htot(I) - Shtot(I))) else - gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(I) - Rhtot(I)) + gHprime = g_H_Rho0 * (US%R_to_kg_m3*GV%Rlay(k)*htot(I) - Rhtot(I)) endif if (gHprime > 0.0) then @@ -1282,7 +1282,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym Thtot(I) = Thtot(I) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) Shtot(I) = Shtot(I) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) else - Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%Rlay(k) + Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * US%R_to_kg_m3*GV%Rlay(k) endif endif ; enddo enddo ; endif @@ -1392,7 +1392,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym else ! Use Rlay as the density variable. Rhtot = 0.0 do k=1,nz-1 - Rlay = GV%Rlay(k) ; Rlb = GV%Rlay(k+1) + Rlay = US%R_to_kg_m3*GV%Rlay(k) ; Rlb = US%R_to_kg_m3*GV%Rlay(k+1) oldfn = Rlay*htot(i) - Rhtot(i) if (oldfn >= ustarsq) exit @@ -1407,7 +1407,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym htot(i) = htot(i) + Dh Rhtot(i) = Rhtot(i) + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (US%R_to_kg_m3*GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & htot(i) = htot(i) + h_at_vel(i,nz) endif ! use_EOS @@ -1487,7 +1487,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & dR_dS(i) * (S_lay*htot(i) - Shtot(i))) else - gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(i) - Rhtot(i)) + gHprime = g_H_Rho0 * (US%R_to_kg_m3*GV%Rlay(k)*htot(i) - Rhtot(i)) endif if (gHprime > 0.0) then @@ -1519,7 +1519,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym Thtot(i) = Thtot(i) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) Shtot(i) = Shtot(i) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) else - Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%Rlay(k) + Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * US%R_to_kg_m3*GV%Rlay(k) endif endif ; enddo enddo ; endif @@ -1629,7 +1629,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym else ! Use Rlay as the density variable. Rhtot = 0.0 do k=1,nz-1 - Rlay = GV%Rlay(k) ; Rlb = GV%Rlay(k+1) + Rlay = US%R_to_kg_m3*GV%Rlay(k) ; Rlb = US%R_to_kg_m3*GV%Rlay(k+1) oldfn = Rlay*htot(i) - Rhtot(i) if (oldfn >= ustarsq) exit @@ -1644,7 +1644,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym htot(i) = htot(i) + Dh Rhtot = Rhtot + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (US%R_to_kg_m3*GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & htot(i) = htot(i) + h_at_vel(i,nz) endif ! use_EOS diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 978e8d1807..744f1fbaf7 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -11,6 +11,7 @@ module MOM_sponge use MOM_grid, only : ocean_grid_type use MOM_spatial_means, only : global_i_mean use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type ! Planned extension: Support for time varying sponge targets. @@ -317,9 +318,10 @@ end subroutine set_up_sponge_ML_density !> This subroutine applies damping to the layers thicknesses, mixed layer buoyancy, and a variety of !! tracers for every column where there is damping. -subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) +subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] real, intent(in) :: dt !< The amount of time covered by this call [s]. @@ -497,7 +499,7 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) wpb = 0.0; wb = 0.0 do k=nz,nkmb+1,-1 - if (GV%Rlay(k) > Rcv_ml(i,j)) then + if (US%R_to_kg_m3*GV%Rlay(k) > Rcv_ml(i,j)) then w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w-ABS(w)) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 5577115a48..bc3e7255d3 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -482,7 +482,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%debug) call MOM_tracer_chksum("Before epipycnal diff ", Reg%Tr, ntr, G) call cpu_clock_begin(id_clock_epimix) - call tracer_epipycnal_ML_diff(h, dt, Reg%Tr, ntr, khdt_x, khdt_y, G, GV, & + call tracer_epipycnal_ML_diff(h, dt, Reg%Tr, ntr, khdt_x, khdt_y, G, GV, US, & CS, tv, num_itts) call cpu_clock_end(id_clock_epimix) endif @@ -541,7 +541,7 @@ end subroutine tracer_hordiff !! Multiple iterations are used (if necessary) so that there is no limit on the !! acceptable time increment. subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & - GV, CS, tv, num_itts) + GV, US, CS, tv, num_itts) 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(in) :: h !< layer thickness [H ~> m or kg m-2] @@ -554,6 +554,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G),SZJB_(G)), intent(in) :: khdt_epi_y !< Meridional epipycnal diffusivity times !! a time step and the ratio of the open face width over !! the distance between adjacent tracer points [L2 ~> m2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_hor_diff_CS), intent(inout) :: CS !< module control structure type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic structure integer, intent(in) :: num_itts !< number of iterations (usually=1) @@ -680,14 +681,14 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel do default(none) shared(is,ie,js,je,nz,nkmb,G,GV,Rml_max,max_kRho) & !$OMP private(k_min,k_max,k_test) do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then - if (Rml_max(i,j) > GV%Rlay(nz)) then ; max_kRho(i,j) = nz+1 - elseif (Rml_max(i,j) <= GV%Rlay(nkmb+1)) then ; max_kRho(i,j) = nkmb+1 + if (Rml_max(i,j) > US%R_to_kg_m3*GV%Rlay(nz)) then ; max_kRho(i,j) = nz+1 + elseif (Rml_max(i,j) <= US%R_to_kg_m3*GV%Rlay(nkmb+1)) then ; max_kRho(i,j) = nkmb+1 else k_min = nkmb+2 ; k_max = nz do k_test = (k_min + k_max) / 2 - if (Rml_max(i,j) <= GV%Rlay(k_test-1)) then ; k_max = k_test-1 - elseif (GV%Rlay(k_test) < Rml_max(i,j)) then ; k_min = k_test+1 + if (Rml_max(i,j) <= US%R_to_kg_m3*GV%Rlay(k_test-1)) then ; k_max = k_test-1 + elseif (US%R_to_kg_m3*GV%Rlay(k_test) < Rml_max(i,j)) then ; k_min = k_test+1 else ; max_kRho(i,j) = k_test ; exit ; endif if (k_min == k_max) then ; max_kRho(i,j) = k_max ; exit ; endif @@ -721,7 +722,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & if ((k<=k_end_srt(i,j)) .and. (h(i,j,k) > h_exclude)) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k - rho_srt(i,ns,j) = GV%Rlay(k) + rho_srt(i,ns,j) = US%R_to_kg_m3*GV%Rlay(k) h_srt(i,ns,j) = h(i,j,k) endif endif ; enddo ; enddo diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 7a2a6bfd90..77e0cb44c8 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -348,11 +348,11 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),tv%eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,tv%eqn_of_state) - do k=1,nz ; T0(k) = T0(1) + (GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo + do k=1,nz ; T0(k) = T0(1) + (US%R_to_kg_m3*GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo do itt=1,6 call calculate_density(T0,S0,pres,rho_guess,1,nz,tv%eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,tv%eqn_of_state) - do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo + do k=1,nz ; T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo ! Temperature on tracer 1??? diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 56ca631022..eda848fd30 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -196,10 +196,11 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read ! Construct notional interface positions e0(1) = 0. do K=2,nz - e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range + e0(k) = -G%max_depth * ( 0.5 * US%R_to_kg_m3*( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range e0(k) = min( 0., e0(k) ) ! Bound by surface e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model - ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) + ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)', & + ! G%max_depth,US%R_to_kg_m3*GV%Rlay(k-1),US%R_to_kg_m3*GV%Rlay(k),e0(k) ! call MOM_mesg(mesg,5) enddo e0(nz+1) = -G%max_depth @@ -248,13 +249,14 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read end subroutine ISOMIP_initialize_thickness !> Initial values for temperature and salinity -subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & +subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, & eqn_of_state, just_read_params) - 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(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 [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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 [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 @@ -364,28 +366,28 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, if (fit_salin) then ! A first guess of the layers' salinity. do k=nz,1,-1 - S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) + S0(k) = max(0.0, S0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dS1) enddo ! Refine the guesses for each layer. do itt=1,6 call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) do k=1,nz - S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) + S0(k) = max(0.0, S0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dS1) enddo enddo else ! A first guess of the layers' temperatures. do k=nz,1,-1 - T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT1 + T0(k) = T0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dT1 enddo do itt=1,6 call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) do k=1,nz - T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo endif @@ -406,8 +408,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, !i=G%iec; j=G%jec !do k = 1,nz ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,eqn_of_state) - ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) - ! call MOM_mesg(mesg,5) + ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,US%R_to_kg_m3*GV%Rlay(k) + ! call MOM_mesg(mesg,5) !enddo end subroutine ISOMIP_initialize_temperature_salinity @@ -536,10 +538,11 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! Construct notional interface positions e0(1) = 0. do K=2,nz - e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range + e0(k) = -G%max_depth * ( 0.5 * US%R_to_kg_m3*( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range e0(k) = min( 0., e0(k) ) ! Bound by surface e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model - ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) + ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',& + ! G%max_depth,US%R_to_kg_m3*GV%Rlay(k-1),US%R_to_kg_m3*GV%Rlay(k),e0(k) ! call MOM_mesg(mesg,5) enddo e0(nz+1) = -G%max_depth @@ -602,7 +605,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) !i=G%iec; j=G%jec !do k = 1,nz ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state) - ! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) + ! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,US%R_to_kg_m3*GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo @@ -653,7 +656,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) !do k = 1,nz ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state) ! write(mesg,*) 'Sponge - k,eta,T,S,rho,Rlay',k,eta(i,j,k),T(i,j,k),& - ! S(i,j,k),rho_tmp,GV%Rlay(k) + ! S(i,j,k),rho_tmp,US%R_to_kg_m3*GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 28033d8799..94bf004907 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -119,10 +119,10 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read e0(k) = -G%max_depth * (real(k-1) / real(nz)) enddo endif - target_values(1) = GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) - target_values(nz+1) = GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) + target_values(1) = US%R_to_kg_m3*( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) + target_values(nz+1) = US%R_to_kg_m3*( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) do k = 2,nz - target_values(k) = target_values(k-1) + ( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) + target_values(k) = target_values(k-1) + US%R_to_kg_m3*( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) enddo target_values(:) = target_values(:) - 1000. do j=js,je ; do i=is,ie diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 859a878446..2c40015acd 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -152,7 +152,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state ! A first guess of the layers' temperatures. do k=1,nz - T0(k) = T0(k1) + (GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) + T0(k) = T0(k1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) enddo ! Refine the guesses for each layer. @@ -160,7 +160,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) do k=1,nz - T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo @@ -208,7 +208,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state end subroutine benchmark_initialize_thickness !> Initializes layer temperatures and salinities for benchmark -subroutine benchmark_init_temperature_salinity(T, S, G, GV, param_file, & +subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & eqn_of_state, P_Ref, 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. @@ -216,6 +216,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, param_file, & !! that is being initialized. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being !! initialized. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for !! model parameter values. @@ -256,7 +257,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, param_file, & ! A first guess of the layers' temperatures. ! do k=1,nz - T0(k) = T0(k1) + (GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) + T0(k) = T0(k1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) enddo ! Refine the guesses for each layer. ! @@ -264,7 +265,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, param_file, & call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) do k=1,nz - T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 64f4f84247..fb9b07f1e0 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -249,7 +249,7 @@ end subroutine write_user_log !! - G%bathyT - Basin depth [Z ~> m]. (Must be positive.) !! - G%CoriolisBu - The Coriolis parameter [T-1 ~> s-1]. !! - GV%g_prime - The reduced gravity at each interface [L2 Z-1 T-2 ~> m s-2]. -!! - GV%Rlay - Layer potential density (coordinate variable) [kg m-3]. +!! - GV%Rlay - Layer potential density (coordinate variable) [R ~> kg m-3]. !! If ENABLE_THERMODYNAMICS is defined: !! - T - Temperature [degC]. !! - S - Salinity [psu]. From bc378e3b238af91b0a6f05cd8ff5e0f5a26cc2b2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Sep 2019 05:30:59 -0400 Subject: [PATCH 090/259] +Move rescaling of Rlay into set_coord routines Moved rescaling of Rlay to [R] into the various set_coord routines. This required the addition of unit_scale_type arguments to two interfaces. All answers are bitwise identical, but new arguments have been added to two public interfaces. --- .../MOM_coord_initialization.F90 | 69 ++++++++----------- src/user/BFB_initialization.F90 | 13 ++-- src/user/user_initialization.F90 | 5 +- 3 files changed, 40 insertions(+), 47 deletions(-) diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index bd7fcccb0c..19cb9774f0 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -84,34 +84,24 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept select case ( trim(config) ) case ("gprime") call set_coord_from_gprime(GV%Rlay, GV%g_prime, GV, US, PF) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("layer_ref") call set_coord_from_layer_density(GV%Rlay, GV%g_prime, GV, US, PF) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("linear") call set_coord_linear(GV%Rlay, GV%g_prime, GV, US, PF) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("ts_ref") call set_coord_from_ts_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("ts_profile") call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("ts_range") call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("file") call set_coord_from_file(GV%Rlay, GV%g_prime, GV, US, PF) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case ("USER") - call user_set_coord(GV%Rlay, GV%g_prime, GV, PF, eos) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) + call user_set_coord(GV%Rlay, GV%g_prime, GV, US, PF, eos) case ("BFB") - call BFB_set_coord(GV%Rlay, GV%g_prime, GV, PF, eos) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) + call BFB_set_coord(GV%Rlay, GV%g_prime, GV, US, PF, eos) case ("none", "ALE") call set_coord_to_none(GV%Rlay, GV%g_prime, GV, US, PF) - GV%Rlay(:) = US%kg_m3_to_R*GV%Rlay(:) case default ; call MOM_error(FATAL,"MOM_initialize_coord: "// & "Unrecognized coordinate setup"//trim(config)) end select @@ -134,7 +124,7 @@ end subroutine MOM_initialize_coord !> Sets the layer densities (Rlay) and the interface reduced gravities (g). subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -158,8 +148,8 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = US%kg_m3_to_R*GV%Rho0 + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(US%kg_m3_to_R*GV%Rho0/GV%g_Earth) ; enddo call callTree_leave(trim(mdl)//'()') @@ -168,7 +158,7 @@ end subroutine set_coord_from_gprime !> Sets the layer densities (Rlay) and the interface reduced gravities (g). subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -189,10 +179,10 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & "The reference potential density used for layer 1.", & - units="kg m-3", default=GV%Rho0) + units="kg m-3", default=GV%Rho0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & "The range of reference potential densities in the layers.", & - units="kg m-3", default=2.0) + units="kg m-3", default=2.0, scale=US%kg_m3_to_R) g_prime(1) = g_fs Rlay(1) = Rlay_Ref @@ -201,7 +191,7 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. ! do k=2,nz - g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -211,7 +201,7 @@ end subroutine set_coord_from_layer_density subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state, & P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -250,10 +240,10 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state ! The uppermost layer's density is set here. Subsequent layers' ! ! densities are determined from this value and the g values. ! ! T0 = 28.228 ; S0 = 34.5848 ; Pref = P_Ref - call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state) + call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state, scale=US%kg_m3_to_R) ! These statements set the layer densities. ! - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(US%kg_m3_to_R*GV%Rho0/GV%g_Earth) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_ref @@ -262,7 +252,7 @@ end subroutine set_coord_from_TS_ref subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & eqn_of_state, P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -300,17 +290,17 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, 1,nz,eqn_of_state) - do k=2,nz; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo + call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) + do k=2,nz; g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_profile !> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a linear T-S profile. subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & - eqn_of_state, P_Ref) + eqn_of_state, P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -380,12 +370,12 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, k_light,nz-k_light+1,eqn_of_state) + call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, scale=US%kg_m3_to_R) ! Extrapolate target densities for the variable density mixed and buffer layers. do k=k_light-1,1,-1 - Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) + Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) enddo - do k=2,nz; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)); enddo + do k=2,nz ; g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_range @@ -393,7 +383,7 @@ end subroutine set_coord_from_TS_range ! Sets the layer densities (Rlay) and the interface reduced gravities (g) from data in file. subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -426,8 +416,9 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) " set_coord_from_file: Unable to open "//trim(filename)) call read_axis_data(filename, coord_var, Rlay) + do k=1,nz ; Rlay(k) = US%kg_m3_to_R*Rlay(k) ; enddo g_prime(1) = g_fs - do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo + do k=2,nz ; g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo do k=1,nz ; if (g_prime(k) <= 0.0) then call MOM_error(FATAL, "MOM_initialization set_coord_from_file: "//& "Zero or negative g_primes read from variable "//"Layer"//" in file "//& @@ -444,7 +435,7 @@ end subroutine set_coord_from_file !! (defaulting to 2.0 if not defined) subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -460,10 +451,10 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & "The reference potential density used for the surface interface.", & - units="kg m-3", default=GV%Rho0) + units="kg m-3", default=GV%Rho0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & "The range of reference potential densities across all interfaces.", & - units="kg m-3", default=2.0) + units="kg m-3", default=2.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) @@ -477,7 +468,7 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) ! These statements set the interface reduced gravities. g_prime(1) = g_fs do k=2,nz - g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -488,7 +479,7 @@ end subroutine set_coord_linear !! might be used. subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density) [kg m-3]. + !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, !! [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -508,8 +499,8 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = US%kg_m3_to_R*GV%Rho0 + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(US%kg_m3_to_R*GV%Rho0/GV%g_Earth) ; enddo call callTree_leave(trim(mdl)//'()') diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 055e6af00f..fcfca47d50 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -35,11 +35,12 @@ module BFB_initialization !! This case is set up in such a way that the temperature of the topmost layer is equal to the SST at the !! southern edge of the domain. The temperatures are then converted to densities of the top and bottom layers !! and linearly interpolated for the intermediate layers. -subroutine BFB_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) - real, dimension(NKMEM_), intent(out) :: Rlay !< Layer potential density. +subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) + real, dimension(NKMEM_), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. real, dimension(NKMEM_), intent(out) :: g_prime !< The reduced gravity at !! each interface [L2 Z-1 T-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(EOS_type), pointer :: eqn_of_state !< Integer that selects the !! equation of state. @@ -50,19 +51,19 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) call get_param(param_file, mdl, "DRHO_DT", drho_dt, & "Rate of change of density with temperature.", & - units="kg m-3 K-1", default=-0.2) + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SST_S", SST_s, & "SST at the suothern edge of the domain.", units="C", default=20.0) call get_param(param_file, mdl, "T_BOT", T_bot, & "Bottom Temp", units="C", default=5.0) - rho_top = GV%rho0 + drho_dt*SST_s - rho_bot = GV%rho0 + drho_dt*T_bot + rho_top = US%kg_m3_to_R*GV%rho0 + drho_dt*SST_s + rho_bot = US%kg_m3_to_R*GV%rho0 + drho_dt*T_bot nz = GV%ke do k = 1,nz Rlay(k) = (rho_bot - rho_top)/(nz-1)*real(k-1) + rho_top if (k >1) then - g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth/GV%rho0 + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (US%kg_m3_to_R*GV%rho0) else g_prime(k) = GV%g_Earth endif diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index fb9b07f1e0..7db78f2454 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -37,12 +37,13 @@ module user_initialization contains !> Set vertical coordinates. -subroutine USER_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) +subroutine USER_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. - real, dimension(:), intent(out) :: Rlay !< Layer potential density. + real, dimension(:), intent(out) :: Rlay !< Layer potential density [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity at !! each interface [L2 Z-1 T-2 ~> m s-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. From ee6baaa23b5bd0179ee41c59932150eacdae96d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Sep 2019 08:23:16 -0400 Subject: [PATCH 091/259] +Changed units of GV%Rho0 to [R] Changed the units of GV%Rho0 from [kg m-3] to [R] for dimensional consistency testing. This required the addition of unit_scale_type arguments to several interfaces. All answers are bitwise identical, but new arguments have been added to several public interfaces and the units of an element in a public type have changed. --- config_src/mct_driver/mom_ocean_model_mct.F90 | 2 +- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 2 +- src/core/MOM.F90 | 4 ++-- src/core/MOM_PressureForce_Montgomery.F90 | 4 ++-- src/core/MOM_PressureForce_analytic_FV.F90 | 4 ++-- src/core/MOM_PressureForce_blocked_AFV.F90 | 4 ++-- src/core/MOM_barotropic.F90 | 8 +++---- src/core/MOM_forcing_type.F90 | 14 ++++++----- src/core/MOM_isopycnal_slopes.F90 | 2 +- src/core/MOM_verticalGrid.F90 | 8 +++---- src/diagnostics/MOM_diagnostics.F90 | 4 ++-- src/diagnostics/MOM_sum_output.F90 | 8 +++---- src/diagnostics/MOM_wave_speed.F90 | 4 ++-- src/diagnostics/MOM_wave_structure.F90 | 6 ++--- .../MOM_coord_initialization.F90 | 24 +++++++++---------- .../MOM_state_initialization.F90 | 23 +++++++++--------- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- .../lateral/MOM_internal_tides.F90 | 4 ++-- .../lateral/MOM_mixed_layer_restrat.F90 | 4 ++-- .../lateral/MOM_thickness_diffuse.F90 | 2 +- .../vertical/MOM_CVMix_KPP.F90 | 2 +- .../vertical/MOM_CVMix_conv.F90 | 2 +- .../vertical/MOM_CVMix_shear.F90 | 2 +- .../vertical/MOM_bulk_mixed_layer.F90 | 18 +++++++------- .../vertical/MOM_diabatic_aux.F90 | 8 +++---- .../vertical/MOM_energetic_PBL.F90 | 8 +++---- .../vertical/MOM_internal_tide_input.F90 | 4 ++-- .../vertical/MOM_kappa_shear.F90 | 2 +- .../vertical/MOM_set_diffusivity.F90 | 24 +++++++++---------- .../vertical/MOM_set_viscosity.F90 | 6 ++--- .../vertical/MOM_tidal_mixing.F90 | 16 ++++++------- .../vertical/MOM_vert_friction.F90 | 4 ++-- src/tracer/MOM_OCMIP2_CFC.F90 | 4 ++-- src/user/BFB_initialization.F90 | 6 ++--- src/user/DOME_initialization.F90 | 2 +- src/user/MOM_wave_interface.F90 | 2 +- src/user/Rossby_front_2d_initialization.F90 | 13 +++++----- 37 files changed, 130 insertions(+), 126 deletions(-) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 4f1c7d963a..8873f283ff 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -582,7 +582,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & #endif endif - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) + call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%US%R_to_kg_m3*OS%GV%Rho0) call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%use_waves) then diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index e04064f672..db475754c9 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -570,7 +570,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average #endif endif - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) + call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%US%R_to_kg_m3*OS%GV%Rho0) call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%use_waves) then diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 775a15b427..7837f72b3b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2678,7 +2678,7 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) 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 + Rho_conv = US%R_to_kg_m3*GV%Rho0 endif IgR0 = 1.0 / (Rho_conv * GV%mks_g_Earth) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 @@ -2914,7 +2914,7 @@ subroutine extract_surface_state(CS, sfc_state) if (G%mask2dT(i,j)>0.) then ! instantaneous melt_potential [J m-2] - sfc_state%melt_potential(i,j) = CS%tv%C_p * CS%GV%Rho0 * delT(i) + sfc_state%melt_potential(i,j) = CS%tv%C_p * CS%US%R_to_kg_m3*GV%Rho0 * delT(i) endif enddo enddo ! end of j loop diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index ebcc3e4afc..e627cba724 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -435,7 +435,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, h_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0/CS%Rho0 - G_Rho0 = GV%g_Earth/GV%Rho0 + G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) if (CS%tides) then ! Determine the surface height anomaly for calculating self attraction @@ -640,7 +640,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke Rho0xG = Rho0*US%L_T_to_m_s**2 * GV%g_Earth - G_Rho0 = GV%g_Earth / GV%Rho0 + G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) use_EOS = associated(tv%eqn_of_state) z_neglect = GV%H_subroundoff*GV%H_to_Z diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 0d56722825..3e1e2f72e1 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -531,9 +531,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z - I_Rho0 = US%m_s_to_L_T**2 / GV%Rho0 + I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - G_Rho0 = GV%g_Earth/GV%Rho0 + G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) rho_ref = CS%Rho0 if (CS%tides) then diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 87b325ef15..87d8d0fc8f 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -515,9 +515,9 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z - I_Rho0 = US%m_s_to_L_T**2 / GV%Rho0 + I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - G_Rho0 = GV%g_Earth / GV%Rho0 + G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) rho_ref = CS%Rho0 if (CS%tides) then diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7b2f367487..fd2d6560be 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -724,8 +724,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dtbt = dt_in_T * Instep bebt = CS%bebt be_proj = CS%bebt - mass_accel_to_Z = US%m_to_L*US%T_to_s**2 * US%m_to_Z / GV%Rho0 - mass_to_Z = US%m_to_Z / GV%Rho0 + mass_accel_to_Z = US%m_to_L*US%T_to_s**2 * US%m_to_Z / (US%R_to_kg_m3*GV%Rho0) + mass_to_Z = US%m_to_Z / (US%R_to_kg_m3*GV%Rho0) !--- setup the weight when computing vbt_trans and ubt_trans if (project_velocity) then @@ -4345,10 +4345,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, enddo ; enddo ! else ! do j=js,je ; do I=is-1,ie -! CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (GV%Rho0*(G%bathyT(i+1,j) + G%bathyT(i,j))) +! CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (US%R_to_kg_m3*GV%Rho0*(G%bathyT(i+1,j) + G%bathyT(i,j))) ! enddo ; enddo ! do J=js-1,je ; do i=is,ie -! CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (GV%Rho0*(G%bathyT(i,j+1) + G%bathyT(i,j))) +! CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (US%R_to_kg_m3*GV%Rho0*(G%bathyT(i,j+1) + G%bathyT(i,j))) ! enddo ; enddo ! endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a8c6f7bf1a..ececc6d1e7 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -336,7 +336,7 @@ module MOM_forcing_type !! for optimization purposes. The 2d (i,j) wrapper is the next subroutine below. !! This routine multiplies fluxes by dt, so that the result is an accumulation of fluxes !! over a time step. -subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & +subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent, & h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & aggregate_FW, nonpenSW, netmassInOut_rate,net_Heat_Rate, & @@ -344,6 +344,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(forcing), intent(inout) :: fluxes !< structure containing pointers to possible !! forcing fields. NULL unused fields. type(optics_type), pointer :: optics !< pointer to optics @@ -433,7 +434,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, !}BGR Ih_limit = 1.0 / FluxRescaleDepth - Irho0 = 1.0 / GV%Rho0 + Irho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) I_Cp = 1.0 / fluxes%C_p J_m2_to_H = 1.0 / (GV%H_to_kg_m2 * fluxes%C_p) @@ -804,13 +805,14 @@ end subroutine extractFluxes1d !> 2d wrapper for 1d extract fluxes from surface fluxes type. !! This subroutine extracts fluxes from the surface fluxes type. It multiplies the !! fluxes by dt, so that the result is an accumulation of the fluxes over a time step. -subroutine extractFluxes2d(G, GV, fluxes, optics, nsw, dt, FluxRescaleDepth, & +subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, & useRiverHeatContent, useCalvingHeatContent, h, T, & netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & aggregate_FW) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(forcing), intent(inout) :: fluxes !< structure containing pointers to forcing. type(optics_type), pointer :: optics !< pointer to optics integer, intent(in) :: nsw !< number of bands of penetrating SW @@ -854,7 +856,7 @@ subroutine extractFluxes2d(G, GV, fluxes, optics, nsw, dt, FluxRescaleDepth, & !$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & !$OMP aggregate_FW) do j=G%jsc, G%jec - call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& h(:,j,:), T(:,j,:), netMassInOut(:,j), netMassOut(:,j), & net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW) @@ -916,7 +918,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt depthBeforeScalingFluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) pressure(:) = 0. ! Ignore atmospheric pressure - GoRho = (GV%g_Earth*US%m_to_Z * GV%H_to_m*US%T_to_s) / GV%Rho0 + GoRho = (GV%g_Earth*US%m_to_Z * GV%H_to_m*US%T_to_s) / (US%R_to_kg_m3*GV%Rho0) start = 1 + G%isc - G%isd npts = 1 + G%iec - G%isc @@ -929,7 +931,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! netSalt = salt via surface fluxes [ppt H s-1 ~> ppt m s-1 or gSalt m-2 s-1] ! Note that unlike other calls to extractFLuxes1d() that return the time-integrated flux ! this call returns the rate because dt=1 - call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & depthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & h(:,j,:), Temp(:,j,:), netH, netEvap, netHeatMinusSW, & netSalt, penSWbnd, tv, .false., skip_diags=skip_diags) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 61118074fd..ae06413e90 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -121,7 +121,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & present_N2_u = PRESENT(N2_u) present_N2_v = PRESENT(N2_v) - G_Rho0 = (US%L_to_Z*L_to_Z*GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z*L_to_Z*GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) if (present_N2_u) then do j=js,je ; do I=is-1,ie N2_u(I,j,1) = 0. diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 2d313c5148..093db28c07 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -101,7 +101,7 @@ subroutine verticalGridInit( param_file, GV, US ) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "BOUSSINESQ", GV%Boussinesq, & "If true, make the Boussinesq approximation.", default=.true.) call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_m, & @@ -143,15 +143,15 @@ subroutine verticalGridInit( param_file, GV, US ) GV%ke = nk if (GV%Boussinesq) then - GV%H_to_kg_m2 = GV%Rho0 * GV%H_to_m + GV%H_to_kg_m2 = US%R_to_kg_m3*GV%Rho0 * GV%H_to_m GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = 1.0 / GV%H_to_m GV%Angstrom_H = GV%m_to_H * GV%Angstrom_m GV%H_to_MKS = GV%H_to_m else GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 - GV%m_to_H = GV%Rho0 * GV%kg_m2_to_H - GV%H_to_m = GV%H_to_kg_m2 / GV%Rho0 + GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H + GV%H_to_m = GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) GV%Angstrom_H = GV%Angstrom_m*1000.0*GV%kg_m2_to_H GV%H_to_MKS = GV%H_to_kg_m2 endif diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 1d9e7f39b7..47aeaf547e 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -842,7 +842,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), & - z_top, z_bot, 0.0, GV%Rho0, GV%mks_g_Earth*US%Z_to_m, & + z_top, z_bot, 0.0, US%R_to_kg_m3*GV%Rho0, GV%mks_g_Earth*US%Z_to_m, & G%HI, G%HI, tv%eqn_of_state, dpress) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth @@ -2006,7 +2006,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) 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', & + 'kg m-3', cmor_field_name='rhozero', conversion=US%R_to_kg_m3, & 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, GV%Rho0, diag, .true.) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index d6f495faa5..9d8cff542f 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -542,7 +542,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ tmp1(i,j,k) = H_to_kg_m2 * h(i,j,k) * areaTm(i,j) enddo ; enddo ; enddo mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = US%m_to_Z * (mass_lay(k) / GV%Rho0) ; enddo + do k=1,nz ; vol_lay(k) = US%m_to_Z * (mass_lay(k) / (US%R_to_kg_m3*GV%Rho0)) ; enddo endif endif ! Boussinesq @@ -666,7 +666,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ hint = Z_0APE(K) + (hbelow - G%bathyT(i,j)) hbot = Z_0APE(K) - G%bathyT(i,j) hbot = (hbot + ABS(hbot)) * 0.5 - PE_pt(i,j,K) = 0.5 * areaTm(i,j) * US%Z_to_m*US%L_T_to_m_s**2*(GV%Rho0*GV%g_prime(K)) * & + PE_pt(i,j,K) = 0.5 * areaTm(i,j) * US%Z_to_m*US%L_T_to_m_s**2*(US%R_to_kg_m3*GV%Rho0*GV%g_prime(K)) * & (hint * hint - hbot * hbot) enddo enddo ; enddo @@ -675,7 +675,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ do k=nz,1,-1 hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. hbot = max(Z_0APE(K) - G%bathyT(i,j), 0.0) - PE_pt(i,j,K) = 0.5 * (areaTm(i,j) * US%Z_to_m*US%L_T_to_m_s**2*(GV%Rho0*GV%g_prime(K))) * & + PE_pt(i,j,K) = 0.5 * (areaTm(i,j) * US%Z_to_m*US%L_T_to_m_s**2*(US%R_to_kg_m3*GV%Rho0*GV%g_prime(K))) * & (hint * hint - hbot * hbot) enddo enddo ; enddo @@ -750,7 +750,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ CS%salt_prev_EFP = salt_EFP ; CS%net_salt_in_EFP = real_to_EFP(0.0) CS%heat_prev_EFP = heat_EFP ; CS%net_heat_in_EFP = real_to_EFP(0.0) endif - Irho0 = 1.0/GV%Rho0 + Irho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) if (CS%use_temperature) then Salt_chg_EFP = Salt_EFP - CS%salt_prev_EFP diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index cd9dd9dbb8..f8ac508a28 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -132,7 +132,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 + g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) Z_to_Pa = GV%Z_to_H * GV%H_to_Pa use_EOS = associated(tv%eqn_of_state) @@ -600,7 +600,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif ; endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 + g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) use_EOS = associated(tv%eqn_of_state) Z_to_Pa = GV%Z_to_H * GV%H_to_Pa diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index d8c7cc5a02..e282b0e43a 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -178,7 +178,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo Pi = (4.0*atan(1.0)) S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth /GV%Rho0 + g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) cg_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. use_EOS = associated(tv%eqn_of_state) @@ -479,8 +479,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Back-calculate amplitude from energy equation if (Kmag2 > 0.0) then !### This should be simpified to use a single division. - KE_term = 0.25*GV%Rho0*( ((1.0 + f2/freq**2) / Kmag2)*int_dwdz2 + int_w2 ) - PE_term = 0.25*GV%Rho0*( int_N2w2/(US%s_to_T*freq)**2 ) + KE_term = 0.25*US%R_to_kg_m3*GV%Rho0*( ((1.0 + f2/freq**2) / Kmag2)*int_dwdz2 + int_w2 ) + PE_term = 0.25*US%R_to_kg_m3*GV%Rho0*( int_N2w2/(US%s_to_T*freq)**2 ) if (En(i,j) >= 0.0) then W0 = sqrt( En(i,j)/(KE_term + PE_term) ) else diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 19cb9774f0..b2519d47ad 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -148,8 +148,8 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo - Rlay(1) = US%kg_m3_to_R*GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(US%kg_m3_to_R*GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = GV%Rho0 + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo call callTree_leave(trim(mdl)//'()') @@ -179,7 +179,7 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & "The reference potential density used for layer 1.", & - units="kg m-3", default=GV%Rho0, scale=US%kg_m3_to_R) + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & "The range of reference potential densities in the layers.", & units="kg m-3", default=2.0, scale=US%kg_m3_to_R) @@ -191,7 +191,7 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. ! do k=2,nz - g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -243,7 +243,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state, scale=US%kg_m3_to_R) ! These statements set the layer densities. ! - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(US%kg_m3_to_R*GV%Rho0/GV%g_Earth) ; enddo + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_ref @@ -291,7 +291,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_ref ; enddo call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) - do k=2,nz; g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_profile @@ -375,7 +375,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) enddo - do k=2,nz ; g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + do k=2,nz ; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_range @@ -418,7 +418,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) call read_axis_data(filename, coord_var, Rlay) do k=1,nz ; Rlay(k) = US%kg_m3_to_R*Rlay(k) ; enddo g_prime(1) = g_fs - do k=2,nz ; g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + do k=2,nz ; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo do k=1,nz ; if (g_prime(k) <= 0.0) then call MOM_error(FATAL, "MOM_initialization set_coord_from_file: "//& "Zero or negative g_primes read from variable "//"Layer"//" in file "//& @@ -451,7 +451,7 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & "The reference potential density used for the surface interface.", & - units="kg m-3", default=GV%Rho0, scale=US%kg_m3_to_R) + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DENSITY_RANGE", Rlay_range, & "The range of reference potential densities across all interfaces.", & units="kg m-3", default=2.0, scale=US%kg_m3_to_R) @@ -468,7 +468,7 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) ! These statements set the interface reduced gravities. g_prime(1) = g_fs do k=2,nz - g_prime(k) = (GV%g_Earth/(US%kg_m3_to_R*GV%Rho0)) * (Rlay(k) - Rlay(k-1)) + g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) enddo call callTree_leave(trim(mdl)//'()') @@ -499,8 +499,8 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo - Rlay(1) = US%kg_m3_to_R*GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(US%kg_m3_to_R*GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = GV%Rho0 + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo call callTree_leave(trim(mdl)//'()') diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 9210da72da..c061169854 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -318,7 +318,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("soliton"); call soliton_initialize_thickness(h, G, GV, US) case ("phillips"); call Phillips_initialize_thickness(h, G, GV, US, PF, & just_read_params=just_read) - case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, & + case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, US, & PF, just_read_params=just_read) case ("USER"); call user_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) @@ -952,7 +952,7 @@ subroutine convert_thickness(h, G, GV, US, tv) max_itt = 10 Boussinesq = GV%Boussinesq I_gEarth = 1.0 / (GV%mks_g_Earth) - Hm_rho_to_Pa = GV%mks_g_Earth * GV%H_to_m ! = GV%H_to_Pa / GV%Rho0 + Hm_rho_to_Pa = GV%mks_g_Earth * GV%H_to_m ! = GV%H_to_Pa / (US%R_to_kg_m3*GV%Rho0) if (Boussinesq) then call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") @@ -995,7 +995,7 @@ subroutine convert_thickness(h, G, GV, US, tv) do k=1,nz ; do j=js,je ; do i=is,ie h(i,j,k) = (h(i,j,k) * US%R_to_kg_m3*GV%Rlay(k)) * Hm_rho_to_Pa * GV%kg_m2_to_H**2 ! This is mathematically equivalent to - ! h(i,j,k) = h(i,j,k) * (US%R_to_kg_m3*GV%Rlay(k) / GV%Rho0) + ! h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) enddo ; enddo ; enddo endif endif @@ -1154,7 +1154,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - call cut_off_column_top(GV%ke, tv, GV, GV%mks_g_Earth*US%Z_to_m, G%bathyT(i,j), & + call cut_off_column_top(GV%ke, tv, GV, US, GV%mks_g_Earth*US%Z_to_m, G%bathyT(i,j), & min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & z_tol=1.0e-5*US%m_to_Z) @@ -1165,11 +1165,12 @@ end subroutine trim_for_ice !> Adjust the layer thicknesses by removing the top of the water column above the !! depth where the hydrostatic pressure matches p_surf -subroutine cut_off_column_top(nk, tv, GV, G_earth, depth, min_thickness, & +subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, & T, T_t, T_b, S, S_t, S_b, p_surf, h, remap_CS, z_tol) integer, intent(in) :: nk !< Number of layers type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: G_earth !< Gravitational acceleration [m2 Z-1 s-2 ~> m s-2] real, intent(in) :: depth !< Depth of ocean column [Z ~> m]. real, intent(in) :: min_thickness !< Smallest thickness allowed [Z ~> m]. @@ -1203,7 +1204,7 @@ subroutine cut_off_column_top(nk, tv, GV, G_earth, depth, min_thickness, & e_top = e(1) do k=1,nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & + P_t, p_surf, US%R_to_kg_m3*GV%Rho0, G_earth, tv%eqn_of_state, & P_b, z_out, z_tol=z_tol) if (z_out>=e(K)) then ! Imposed pressure was less that pressure at top of cell @@ -2406,15 +2407,15 @@ subroutine MOM_state_init_tests(G, GV, US, tv) S_t(k) = 35.-(0./500.)*e(k) S(k) = 35.+(0./500.)*z(k) S_b(k) = 35.-(0./500.)*e(k+1) - call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -GV%Rho0*GV%mks_g_Earth*z(k), & + call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -US%R_to_kg_m3*GV%Rho0*GV%mks_g_Earth*z(k), & rho(k), tv%eqn_of_state) P_tot = P_tot + GV%mks_g_Earth * rho(k) * h(k) enddo P_t = 0. do k = 1, nk - call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, 0.5*P_tot, GV%Rho0, GV%mks_g_Earth, tv%eqn_of_state, P_b, z_out) + call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), P_t, 0.5*P_tot, & + US%R_to_kg_m3*GV%Rho0, GV%mks_g_Earth, tv%eqn_of_state, P_b, z_out) write(0,*) k,P_t,P_b,0.5*P_tot,e(K),e(K+1),z_out P_t = P_b enddo @@ -2424,8 +2425,8 @@ subroutine MOM_state_init_tests(G, GV, US, tv) write(0,*) ' ==================================================================== ' write(0,*) '' write(0,*) h - call cut_off_column_top(nk, tv, GV, GV%mks_g_Earth, -e(nk+1), GV%Angstrom_H, & - T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS) + call cut_off_column_top(nk, tv, GV, US, GV%mks_g_Earth, -e(nk+1), GV%Angstrom_H, & + T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS) write(0,*) h end subroutine MOM_state_init_tests diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index dc44601f71..cdaa8151c9 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -675,7 +675,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & (G%dF_dy(i,j) + beta_topo_y)**2 ) - I_H = US%L_to_m*GV%Rho0 * I_mass(i,j) + I_H = US%L_to_m*US%R_to_kg_m3*GV%Rho0 * I_mass(i,j) if (KhCoeff*SN*I_H>0.) then ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 9014cb1dbb..4f91cd7ea5 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -202,7 +202,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle - I_rho0 = 1.0 / GV%Rho0 + I_rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) dt_in_T = US%s_to_T*dt cn_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. @@ -2307,7 +2307,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) h2(i,j) = min(0.01*(G%bathyT(i,j))**2, h2(i,j)) ! Compute the fixed part; units are [kg m-2] here ! will be multiplied by N and En to get into [W m-2] - CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0 * US%L_to_Z*kappa_itides * h2(i,j) + CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*US%R_to_kg_m3*GV%Rho0 * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo deallocate(h2) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index ba241ea4b1..ca62160bc1 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -282,7 +282,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in uDml(:) = 0.0 ; vDml(:) = 0.0 uDml_slow(:) = 0.0 ; vDml_slow(:) = 0.0 I4dt = 0.25 / (dt_in_T) - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z proper_averaging = .not. CS%MLE_use_MLD_ave_bug @@ -616,7 +616,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / (dt_in_T) - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index dc235a369e..63385733ec 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -649,7 +649,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, G_scale = GV%g_Earth*US%L_to_m**2*US%s_to_T**3 * GV%H_to_m h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 dz_neglect = GV%H_subroundoff*GV%H_to_Z - G_rho0 = GV%g_Earth / GV%Rho0 + G_rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) N2_floor = CS%N2_floor*US%Z_to_L**2 use_EOS = associated(tv%eqn_of_state) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 2ff0b3efe1..f5ee25c743 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -953,7 +953,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF #endif ! some constants - GoRho = GV%mks_g_Earth / GV%Rho0 + GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 1fbbc15120..19a71116f3 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -172,7 +172,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) real :: pref, rhok, rhokm1, dz, dh, hcorr integer :: i, j, k - g_o_rho0 = GV%mks_g_Earth / GV%Rho0 + g_o_rho0 = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) ! initialize dummy variables rho_lwr(:) = 0.0; rho_1d(:) = 0.0 diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 3ab0567db1..68081a97d9 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -82,7 +82,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) real, parameter :: epsln = 1.e-10 !< Threshold to identify vanished layers ! some constants - GoRho = GV%mks_g_Earth / GV%Rho0 + GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) do j = G%jsc, G%jec do i = G%isc, G%iec diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 1dfb1c36e4..aa101fb9f1 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -372,7 +372,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, ! dt_in_T = dt * US%s_to_T - Irho0 = 1.0 / (US%kg_m3_to_R*GV%Rho0) + Irho0 = 1.0 / (GV%Rho0) dt__diag = dt_in_T ; if (present(dt_diag)) dt__diag = dt_diag Idt_diag = 1.0 / (dt__diag) write_diags = .true. ; if (present(last_call)) write_diags = last_call @@ -533,7 +533,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, ! net_heat = heat via surface fluxes [degC H ~> degC m or degC kg m-2] ! net_salt = salt via surface fluxes [ppt H ~> dppt m or gSalt m-2] ! Pen_SW_bnd = components to penetrative shortwave radiation - call extractFluxes1d(G, GV, fluxes, optics, nsw, j, US%T_to_s*dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, US%T_to_s*dt_in_T, & CS%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) @@ -865,7 +865,7 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & integer :: is, ie, nz, i, k, k1, nzc, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * US%kg_m3_to_R*GV%Rho0) + g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) nzc = nz ; if (present(nz_conv)) nzc = nz_conv nkmb = CS%nkml+CS%nkbl @@ -1068,7 +1068,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * US%kg_m3_to_R*GV%Rho0) + g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) Idt = 1.0 / dt_in_T is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1611,7 +1611,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & integer :: is, ie, nz, i, k, ks, itt, n C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 ; C1_24 = 1.0/24.0 - g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * US%kg_m3_to_R*GV%Rho0) + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) Hmix_min = CS%Hmix_min h_neglect = GV%H_subroundoff is = G%isc ; ie = G%iec ; nz = GV%ke @@ -2362,9 +2362,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea nkmb = CS%nkml+CS%nkbl h_neglect = GV%H_subroundoff g_2 = 0.5 * GV%g_Earth - Rho0xG = US%kg_m3_to_R*GV%Rho0 * GV%g_Earth + Rho0xG = GV%Rho0 * GV%g_Earth Idt_H2 = GV%H_to_Z**2 / dt_diag - I2Rho0 = 0.5 / (US%kg_m3_to_R*GV%Rho0) + I2Rho0 = 0.5 / (GV%Rho0) Angstrom = GV%Angstrom_H ! This is hard coding of arbitrary and dimensional numbers. @@ -2802,7 +2802,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & (R0_det-R0(i,0))*h_det_to_h2 ) + & - h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*US%kg_m3_to_R*GV%Rho0*dPE_extrap ) + h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap ) if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + s1en @@ -3163,7 +3163,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea "CS%nkbl must be 1 in mixedlayer_detrain_1.") dt_Time = dt_in_T / CS%BL_detrain_time - g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * US%kg_m3_to_R*GV%Rho0 * dt_diag) + g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0 * dt_diag) g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) ! Move detrained water into the buffer layer. diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 96652a9f45..b50011efed 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -750,7 +750,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq - gE_rho0 = US%L_to_Z**2*GV%g_Earth / GV%Rho0 + gE_rho0 = US%L_to_Z**2*GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) dH_subML = 50.*GV%m_to_H ; if (present(dz_subML)) dH_subML = GV%Z_to_H*dz_subML is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -946,7 +946,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then SurfPressure(:) = 0.0 - GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 + GoRho = US%L_to_Z**2*GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) start = 1 + G%isc - G%isd npts = 1 + G%iec - G%isc endif @@ -1053,14 +1053,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! but do change answers. !----------------------------------------------------------------------------------------- if (calculate_buoyancy) then - call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW, & net_Heat_rate=netheat_rate, net_salt_rate=netsalt_rate, & netmassinout_rate=netmassinout_rate, pen_sw_bnd_rate=pen_sw_bnd_rate) else - call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 5527866793..a99aa7c1e2 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -789,7 +789,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs max_itt = 20 h_tt_min = 0.0 - I_dtrho = 0.0 ; if (dt*GV%Rho0 > 0.0) I_dtrho = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + I_dtrho = 0.0 ; if (dt*GV%Rho0 > 0.0) I_dtrho = (US%Z_to_m**3*US%s_to_T**3) / (dt*US%R_to_kg_m3*GV%Rho0) vstar_unit_scale = US%m_to_Z * US%T_to_s MLD_guess = MLD_io @@ -863,9 +863,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !/ Apply MStar to get mech_TKE if ((CS%answers_2018) .and. (CS%mstar_scheme==Use_Fixed_MStar)) then - mech_TKE = (dt*MSTAR_total*GV%Rho0) * u_star**3 + mech_TKE = (dt*MSTAR_total*US%R_to_kg_m3*GV%Rho0) * u_star**3 else - mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) + mech_TKE = MSTAR_total * (dt*US%R_to_kg_m3*GV%Rho0* u_star**3) endif if (CS%TKE_diagnostics) then @@ -970,7 +970,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! on a curve fit from the data of Wang (GRL, 2003). ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*htot)**3 / conv_PErel) nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & - sqrt(0.5 * dt * GV%Rho0 * (absf*(htot*GV%H_to_Z))**3 * conv_PErel)) + sqrt(0.5 * dt * US%R_to_kg_m3*GV%Rho0 * (absf*(htot*GV%H_to_Z))**3 * conv_PErel)) endif if (debug) nstar_k(K) = nstar_FC diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 5a9b9b5bbd..36066a20fb 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -185,7 +185,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) logical :: do_i(SZI_(G)), do_any integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) ! Find the (limited) density jump across each interface. do i=is,ie @@ -403,7 +403,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) itide%h2(i,j) = min((max_frac_rough*G%bathyT(i,j))**2, itide%h2(i,j)) ! Compute the fixed part of internal tidal forcing; units are [J m-2] here. - CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& + CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*US%R_to_kg_m3*GV%Rho0*& kappa_itides * US%Z_to_m**2*itide%h2(i,j) * itide%tideamp(i,j)**2 enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 437c52bd6d..3cc1e3b34d 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -793,7 +793,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & Ri_crit = CS%Rino_crit gR0 = GV%z_to_H*GV%H_to_Pa - g_R0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 + g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (US%R_to_kg_m3*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 ? diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9a73801b1b..de312ce1c0 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -279,7 +279,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& "Module must be initialized before it is used.") - I_Rho0 = 1.0 / GV%Rho0 + I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) ! ### Dimensional parameters if (CS%answers_2018) then kappa_dt_fill = US%m_to_Z**2 * 1.e-3 * 7200. @@ -509,7 +509,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri Kd_lay(i,j,k) = max(Kd_lay(i,j,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2)))) + dissip * (CS%FluxRi_max / (US%R_to_kg_m3*GV%Rho0 * (N2_lay(i,k) + Omega2)))) enddo ; enddo if (present(Kd_int)) then ; do K=2,nz ; do i=is,ie @@ -517,13 +517,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri Kd_int(i,j,K) = max(Kd_int(i,j,K) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2)))) + dissip * (CS%FluxRi_max / (US%R_to_kg_m3*GV%Rho0 * (N2_int(i,K) + Omega2)))) enddo ; enddo ; endif endif if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%Rho0 * Kd_lay(i,j,k) * N2_lay(i,k) * & + dd%Kd_Work(i,j,k) = US%R_to_kg_m3*GV%Rho0 * Kd_lay(i,j,k) * N2_lay(i,k) * & GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 enddo ; enddo endif @@ -690,9 +690,9 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & I_dt = 1.0 / dt Omega2 = CS%omega**2 H_neglect = GV%H_subroundoff - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) if (CS%answers_2018) then - I_Rho0 = 1.0 / GV%Rho0 + I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) G_IRho0 = (US%L_to_Z**2 * GV%g_Earth) * I_Rho0 else G_IRho0 = G_Rho0 @@ -890,7 +890,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -1177,8 +1177,8 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE_Ray = 0.0 ; Rayleigh_drag = .false. if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0/GV%Rho0 - R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) + I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) + R0_g = US%R_to_kg_m3*GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(US%R_to_kg_m3*GV%Rlay(k-1)+US%R_to_kg_m3*GV%Rlay(k)) ; enddo @@ -1394,7 +1394,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Determine whether to add Rayleigh drag contribution to TKE Rayleigh_drag = .false. if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0/GV%Rho0 + I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) cdrag_sqrt = sqrt(CS%cdrag) do i=G%isc,G%iec ! Developed in single-column mode @@ -1818,7 +1818,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) enddo if (CS%bulkmixedlayer) then - g_R0 = GV%g_Earth / GV%Rho0 + g_R0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) kmb = GV%nk_rho_varies eps = 0.1 do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo @@ -2122,7 +2122,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) CS%dissip_N2 = 0.0 if (CS%FluxRi_max > 0.0) & - CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max + CS%dissip_N2 = CS%dissip_Kd_min * US%R_to_kg_m3*GV%Rho0 / CS%FluxRi_max CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', & diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 02b5c9691d..00d964106d 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -269,7 +269,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff - Rho0x400_G = 400.0*(GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H + Rho0x400_G = 400.0*(US%R_to_kg_m3*GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H Vol_quit = 0.9*GV%Angstrom_H + h_neglect C2pi_3 = 8.0*atan(1.0)/3.0 @@ -1134,7 +1134,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym Jsq = js-1 ; Isq = is-1 endif ; endif - Rho0x400_G = 400.0*(GV%Rho0/(US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H + Rho0x400_G = 400.0*(US%R_to_kg_m3*GV%Rho0/(US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) @@ -1144,7 +1144,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym dt_Rho0 = US%T_to_s*dt_in_T / GV%H_to_kg_m2 h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect - g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / GV%Rho0 + g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (US%R_to_kg_m3*GV%Rho0) if (associated(forces%frac_shelf_u) .neqv. associated(forces%frac_shelf_v)) & call MOM_error(FATAL, "set_viscous_ML: one of forces%frac_shelf_u and "//& diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index fd910697af..aa158581fc 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -480,7 +480,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) utide = CS%tideamp(i,j) ! Compute the fixed part of internal tidal forcing. ! The units here are [kg Z3 m-3 T-2 ~> J m-2 = kg s-2] here. - CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%Rho0 * & + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * US%R_to_kg_m3*GV%Rho0 * & CS%kappa_itides * CS%h2(i,j) * utide*utide enddo ; enddo @@ -1021,7 +1021,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) enddo ; enddo - I_Rho0 = 1.0/GV%Rho0 + I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09)) .or. & @@ -1255,7 +1255,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, if (k 0) then !$OMP parallel do default(shared) private(trunc_any,CFL) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 0268c04f17..a5fc04fc06 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -460,9 +460,9 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS ! The -GV%Rho0 changes the sign convention of the flux and changes the units ! of the flux from [Conc. m s-1] to [Conc. kg m-2 s-1]. call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, ind_flux, & - CFC11_flux, -GV%Rho0, idim=idim, jdim=jdim) + CFC11_flux, -G%US%R_to_kg_m3*GV%Rho0, idim=idim, jdim=jdim) call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, ind_flux, & - CFC12_flux, -GV%Rho0, idim=idim, jdim=jdim) + CFC12_flux, -G%US%R_to_kg_m3*GV%Rho0, idim=idim, jdim=jdim) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index fcfca47d50..546efcf0b9 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -56,14 +56,14 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file, eqn_of_state) "SST at the suothern edge of the domain.", units="C", default=20.0) call get_param(param_file, mdl, "T_BOT", T_bot, & "Bottom Temp", units="C", default=5.0) - rho_top = US%kg_m3_to_R*GV%rho0 + drho_dt*SST_s - rho_bot = US%kg_m3_to_R*GV%rho0 + drho_dt*T_bot + rho_top = GV%Rho0 + drho_dt*SST_s + rho_bot = GV%Rho0 + drho_dt*T_bot nz = GV%ke do k = 1,nz Rlay(k) = (rho_bot - rho_top)/(nz-1)*real(k-1) + rho_top if (k >1) then - g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (US%kg_m3_to_R*GV%rho0) + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (GV%Rho0) else g_prime(k) = GV%g_Earth endif diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 77e0cb44c8..fa3a18b411 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -290,7 +290,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) if (.not.associated(OBC)) return - g_prime_tot = (GV%g_Earth / GV%Rho0)*2.0 + g_prime_tot = (GV%g_Earth / (US%R_to_kg_m3*GV%Rho0))*2.0 Def_Rad = US%L_to_m*sqrt(D_edge*g_prime_tot) / (1.0e-4*US%T_to_s * 1000.0) tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*US%m_to_L*Def_Rad) * GV%Z_to_H diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 0da6285f37..a048d85491 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1024,7 +1024,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(US%Z_to_m*US%s_to_T*ustar*sqrt(GV%Rho0/1.225), u10, GV, US) + call ust_2_u10_coare3p5(US%Z_to_m*US%s_to_T*ustar*sqrt(US%R_to_kg_m3*GV%Rho0/1.225), u10, GV, US) ! surface Stokes drift UStokes = us_to_u10*u10 ! diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index b991fa95bc..2ef4dbd644 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -36,9 +36,10 @@ module Rossby_front_2d_initialization contains !> Initialization of thicknesses in 2D Rossby front test -subroutine Rossby_front_initialize_thickness(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 +subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read_params) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -78,7 +79,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par case (REGRIDDING_LAYER, REGRIDDING_RHO) do j = G%jsc,G%jec ; do i = G%isc,G%iec Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + eta = -( -dRho_DT / (US%R_to_kg_m3*GV%Rho0) ) * Tz * 0.5 * ( Dml * Dml ) stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz @@ -89,7 +90,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) do j = G%jsc,G%jec ; do i = G%isc,G%iec Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + eta = -( -dRho_DT / (US%R_to_kg_m3*GV%Rho0) ) * Tz * 0.5 * ( Dml * Dml ) stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz @@ -205,7 +206,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 f = 0.5* (G%CoriolisBu(I,j) + G%CoriolisBu(I,j-1) ) dUdT = 0.0 ; if (abs(f) > 0.0) & - dUdT = ( GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) + dUdT = ( GV%g_Earth*dRho_dT ) / ( f * US%R_to_kg_m3*GV%Rho0 ) Dml = Hml( G, G%geoLatT(i,j) ) Ty = US%L_to_m*dTdy( G, T_range, G%geoLatT(i,j) ) zi = 0. From 59036c1286047477aaa0c584f804b22a120c1fb2 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 27 Sep 2019 10:54:48 -0600 Subject: [PATCH 092/259] Remove extraneous 'debugging' statements --- src/tracer/MOM_neutral_diffusion.F90 | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ae17f8c9a8..80c6aa242f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -519,11 +519,6 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) 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 ) ) -! if (tracer%t(i,j,k) < 0.) then -! do ks = 1,CS%nsurf-1 -! print *, uFlx(I,j,ks), uFlx(I-1,j,ks), vFlx(i,J,ks), vFlx(i,J-1,ks) -! enddo -! endif enddo if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then @@ -1311,25 +1306,18 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T ! Handle all the special cases EXCEPT if it connects within the layer if ( (dRhoTop > 0.) .or. (ksurf == 1) ) then ! First interface or lighter than anything in layer pos = pos_last - if (CS%debug) print *, "Lighter" elseif ( dRhoTop > dRhoBot ) then ! Unstably stratified pos = 1. - if (CS%debug) print *, "Unstable" elseif ( dRhoTop < 0. .and. dRhoBot < 0.) then ! Denser than anything in layer pos = 1. - if (CS%debug) print *, "Denser" elseif ( dRhoTop == 0. .and. dRhoBot == 0. ) then ! Perfectly unstratified pos = 1. - if (CS%debug) print *, "Unstratified" elseif ( dRhoBot == 0. ) then ! Matches perfectly at the Top pos = 1. - if (CS%debug) print *, "Bottom" elseif ( dRhoTop == 0. ) then ! Matches perfectly at the Bottom pos = pos_last - if (CS%debug) print *, "Top" else ! Neutral surface within layer pos = -1 - if (CS%debug) print *, "Interpolate" endif ! Can safely return if position is >= 0 otherwise will need to find the position within the layer @@ -1447,7 +1435,6 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r return endif if ( SIGN(1.,drho_min) == SIGN(1.,drho_max) ) then - print *, drho_min, drho_max call MOM_error(FATAL, "drho_min is the same sign as dhro_max") endif @@ -1552,8 +1539,6 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly return endif if ( SIGN(1.,drho_b) == SIGN(1.,drho_c) ) then -! print *, drho_b, drho_c -! call MOM_error(WARNING, "drho_b is the same sign as dhro_c") z = z0 return endif From f7b4b77fec5227572ed1c5d827089aba1bf0cea1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 03:40:17 -0400 Subject: [PATCH 093/259] Rescaled density units in MOM_regularize_layers Rescaled density units in MOM_regularize_layers for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_regularize_layers.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 541302a7c9..d2b326bac6 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -161,7 +161,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_2d, & ! A 2-d version of h [H ~> m or kg m-2]. T_2d, & ! A 2-d version of tv%T [degC]. S_2d, & ! A 2-d version of tv%S [ppt]. - Rcv, & ! A 2-d version of the coordinate density [kg m-3]. + Rcv, & ! A 2-d version of the coordinate density [R ~> kg m-3]. h_2d_init, & ! The initial value of h_2d [H ~> m or kg m-2]. T_2d_init, & ! THe initial value of T_2d [degC]. S_2d_init, & ! The initial value of S_2d [ppt]. @@ -196,7 +196,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real :: h_det_tot real :: max_def_rat real :: Rcv_min_det ! The lightest (min) and densest (max) coordinate density - real :: Rcv_max_det ! that can detrain into a layer [kg m-3]. + real :: Rcv_max_det ! that can detrain into a layer [R ~> kg m-3]. real :: int_top, int_bot real :: h_predicted @@ -444,7 +444,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) call cpu_clock_begin(id_clock_EOS) do k=1,nkmb call calculate_density(T_2d(:,k),S_2d(:,k),p_ref_cv,Rcv(:,k), & - is,ie-is+1,tv%eqn_of_state) + is,ie-is+1,tv%eqn_of_state, scale=US%kg_m3_to_R) enddo call cpu_clock_end(id_clock_EOS) @@ -455,11 +455,11 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (k1 <= 1) exit if (k2 <= nkmb) exit ! ### The 0.6 here should be adjustable? It gives 20% overlap for now. - Rcv_min_det = US%R_to_kg_m3*(GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2-1)-GV%Rlay(k2))) + Rcv_min_det = (GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2-1)-GV%Rlay(k2))) if (k2 < nz) then - Rcv_max_det = US%R_to_kg_m3*(GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2+1)-GV%Rlay(k2))) + Rcv_max_det = (GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2+1)-GV%Rlay(k2))) else - Rcv_max_det = US%R_to_kg_m3*(GV%Rlay(nz) + 0.6*Rcv_tol(i)*(GV%Rlay(nz)-GV%Rlay(nz-1))) + Rcv_max_det = (GV%Rlay(nz) + 0.6*Rcv_tol(i)*(GV%Rlay(nz)-GV%Rlay(nz-1))) endif if (Rcv(i,k1) > Rcv_max_det) & exit ! All shallower interior layers are too light for detrainment. From 297ffe5c3fd310dc0c9891573774c18d05d76c5b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 03:42:08 -0400 Subject: [PATCH 094/259] Rescaled density units in MOM_set_viscosity Rescaled density units in MOM_set_viscosity for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_set_viscosity.F90 | 94 +++++++++---------- 1 file changed, 47 insertions(+), 47 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 00d964106d..c3985e2a7d 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -135,15 +135,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) S_EOS, & ! The salinity used to calculate the partial derivatives ! of density with T and S [ppt]. dR_dT, & ! Partial derivative of the density in the bottom boundary - ! layer with temperature [kg m-3 degC-1]. + ! layer with temperature [R degC-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density in the bottom boundary - ! layer with salinity [kg m-3 ppt-1]. + ! layer with salinity [R ppt-1 ~> kg m-3 ppt-1]. press ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. real :: Rhtot ! Running sum of thicknesses times the layer potential - ! densities [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! densities [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZIB_(G),SZJ_(G)) :: & D_u, & ! Bottom depth interpolated to u points [Z ~> m]. mask_u ! A mask that disables any contributions from u points that @@ -163,21 +163,21 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) S_vel, & ! Arithmetic mean of the layer salinities adjacent to a ! velocity point [ppt]. Rml_vel ! Arithmetic mean of the layer coordinate densities adjacent - ! to a velocity point [kg m-3]. + ! to a velocity point [R ~> kg m-3]. real :: h_vel_pos ! The arithmetic mean thickness at a velocity point ! plus H_neglect to avoid 0 values [H ~> m or kg m-2]. real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion - ! from m to thickness units [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion ! factor from lateral lengths to vertical depths [Z L-1 ~> 1]. real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, - ! divided by G_Earth [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining - ! the layer [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! the layer [H R ~> kg m-2 or kg2 m-5]. real :: Dh ! The increment in layer thickness from ! the present layer [H ~> m or kg m-2]. real :: bbl_thick ! The thickness of the bottom boundary layer [H ~> m or kg m-2]. @@ -198,10 +198,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! of the bottom [H ~> m or kg m-2]. real :: v_at_u, u_at_v ! v at a u point or vice versa [L T-1 ~> m s-1]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [kg T2 H m-3 Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: & - Rml ! The mixed layer coordinate density [kg m-3]. + Rml ! The mixed layer coordinate density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [Pa] (usually set to 2e7 Pa = 2000 dbar). @@ -269,7 +269,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff - Rho0x400_G = 400.0*(US%R_to_kg_m3*GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H + Rho0x400_G = 400.0*(GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H Vol_quit = 0.9*GV%Angstrom_H + h_neglect C2pi_3 = 8.0*atan(1.0)/3.0 @@ -304,7 +304,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nkmb call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, & - Rml(:,j,k), Isq, Ieq-Isq+2, tv%eqn_of_state) + Rml(:,j,k), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo ; enddo endif @@ -545,7 +545,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) press(i) = press(i) + GV%H_to_Pa * h_vel(i,k) enddo ; enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=is,ie ; if (do_i(i)) then @@ -574,7 +574,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) + Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif htot = htot + Dh @@ -589,19 +589,19 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) else ! Use Rlay and/or the coordinate density as density variables. Rhtot = 0.0 do k=nz,K2,-1 - oldfn = Rhtot - US%R_to_kg_m3*GV%Rlay(k)*htot - Dfn = (US%R_to_kg_m3*GV%Rlay(k) - US%R_to_kg_m3*GV%Rlay(k-1))*(h_at_vel(i,k)+htot) + oldfn = Rhtot - GV%Rlay(k)*htot + Dfn = (GV%Rlay(k) - GV%Rlay(k-1))*(h_at_vel(i,k)+htot) if (oldfn >= ustarsq) then cycle elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) + Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif htot = htot + Dh - Rhtot = Rhtot + US%R_to_kg_m3*GV%Rlay(k)*Dh + Rhtot = Rhtot + GV%Rlay(k)*Dh enddo if (nkml>0) then do k=nkmb,2,-1 @@ -613,7 +613,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) + Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif htot = htot + Dh @@ -621,7 +621,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) enddo if (Rhtot - Rml_vel(i,1)*htot < ustarsq) htot = htot + h_at_vel(i,1) else - if (Rhtot - US%R_to_kg_m3*GV%Rlay(1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - GV%Rlay(1)*htot < ustarsq) htot = htot + h_at_vel(i,1) endif endif ! use_BBL_EOS @@ -1034,15 +1034,15 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym Shtot, & ! The integrated salt of layers that are within the ! surface mixed layer [H ppt ~> m ppt or kg ppt m-2]. Rhtot, & ! The integrated density of layers that are within the surface mixed layer - ! [H kg m-3 ~> kg m-2 or kg2 m-5]. Rhtot is only used if no + ! [H R ~> kg m-2 or kg2 m-5]. Rhtot is only used if no ! equation of state is used. uhtot, & ! The depth integrated zonal and meridional velocities within vhtot, & ! the surface mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. dR_dT, & ! Partial derivative of the density at the base of layer nkml - ! (roughly the base of the mixed layer) with temperature [kg m-3 degC-1]. + ! (roughly the base of the mixed layer) with temperature [R degC-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density at the base of layer nkml - ! (roughly the base of the mixed layer) with salinity [kg m-3 ppt-1]. + ! (roughly the base of the mixed layer) with salinity [R ppt-1 ~> kg m-3 ppt-1]. ustar, & ! The surface friction velocity under ice shelves [Z T-1 ~> m s-1]. press, & ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [degC] @@ -1076,8 +1076,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym real :: I_2hlay ! 1 / 2*hlay [H-1 ~> m-1 or m2 kg-1]. real :: T_lay ! The layer temperature at velocity points [degC]. real :: S_lay ! The layer salinity at velocity points [ppt]. - real :: Rlay ! The layer potential density at velocity points [kg m-3]. - real :: Rlb ! The potential density of the layer below [kg m-3]. + real :: Rlay ! The layer potential density at velocity points [R ~> kg m-3]. + real :: Rlb ! The potential density of the layer below [R ~> kg m-3]. real :: v_at_u ! The meridonal velocity at a zonal velocity point [L T-1 ~> m s-1]. real :: u_at_v ! The zonal velocity at a meridonal velocity point [L T-1 ~> m s-1]. real :: gHprime ! The mixed-layer internal gravity wave speed squared, based @@ -1089,18 +1089,18 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym real :: dt_Rho0 ! The time step divided by the conversion from the layer ! thickness to layer mass [s H m2 kg-1 ~> s m3 kg-1 or s]. real :: g_H_Rho0 ! The gravitational acceleration times the conversion from H to m divided - ! by the mean density [L2 m3 T-2 H-1 kg-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + ! by the mean density [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion - ! from m to thickness units [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion ! factor from lateral lengths to vertical depths [Z L-1 ~> 1]. real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, - ! divided by G_Earth [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining - ! the layer [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! the layer [H R ~> kg m-2 or kg2 m-5]. real :: Dh ! The increment in layer thickness from ! the present layer [H ~> m or kg m-2]. real :: U_bg_sq ! The square of an assumed background velocity, for @@ -1113,7 +1113,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [kg T2 H m-3 Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real :: ustar1 ! ustar [H T-1 ~> m s-1 or kg m-2 s-1] real :: h2f2 ! (h*2*f)^2 [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] @@ -1134,7 +1134,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym Jsq = js-1 ; Isq = is-1 endif ; endif - Rho0x400_G = 400.0*(US%R_to_kg_m3*GV%Rho0/(US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H + Rho0x400_G = 400.0*(GV%Rho0/(US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) @@ -1144,7 +1144,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym dt_Rho0 = US%T_to_s*dt_in_T / GV%H_to_kg_m2 h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect - g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (US%R_to_kg_m3*GV%Rho0) + g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (GV%Rho0) if (associated(forces%frac_shelf_u) .neqv. associated(forces%frac_shelf_v)) & call MOM_error(FATAL, "set_viscous_ML: one of forces%frac_shelf_u and "//& @@ -1232,7 +1232,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym S_EOS(I) = (h(i,j,k2)*tv%S(i,j,k2) + h(i+1,j,k2)*tv%S(i+1,j,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state) + Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1250,7 +1250,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & dR_dS(I) * (S_lay*htot(I) - Shtot(I))) else - gHprime = g_H_Rho0 * (US%R_to_kg_m3*GV%Rlay(k)*htot(I) - Rhtot(I)) + gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(I) - Rhtot(I)) endif if (gHprime > 0.0) then @@ -1282,7 +1282,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym Thtot(I) = Thtot(I) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) Shtot(I) = Shtot(I) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) else - Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * US%R_to_kg_m3*GV%Rlay(k) + Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%Rlay(k) endif endif ; enddo enddo ; endif @@ -1353,7 +1353,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), & - dR_dT, dR_dS, Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state) + dR_dT, dR_dS, Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1376,7 +1376,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) + Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif htot(i) = htot(i) + Dh @@ -1392,7 +1392,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym else ! Use Rlay as the density variable. Rhtot = 0.0 do k=1,nz-1 - Rlay = US%R_to_kg_m3*GV%Rlay(k) ; Rlb = US%R_to_kg_m3*GV%Rlay(k+1) + Rlay = GV%Rlay(k) ; Rlb = GV%Rlay(k+1) oldfn = Rlay*htot(i) - Rhtot(i) if (oldfn >= ustarsq) exit @@ -1401,13 +1401,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) + Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif htot(i) = htot(i) + Dh Rhtot(i) = Rhtot(i) + Rlay*Dh enddo - if (US%R_to_kg_m3*GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & htot(i) = htot(i) + h_at_vel(i,nz) endif ! use_EOS @@ -1469,7 +1469,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym S_EOS(i) = (h(i,j,k2)*tv%S(i,j,k2) + h(i,j+1,k2)*tv%S(i,j+1,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=is,ie ; if (do_i(i)) then @@ -1487,7 +1487,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & dR_dS(i) * (S_lay*htot(i) - Shtot(i))) else - gHprime = g_H_Rho0 * (US%R_to_kg_m3*GV%Rlay(k)*htot(i) - Rhtot(i)) + gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(i) - Rhtot(i)) endif if (gHprime > 0.0) then @@ -1519,7 +1519,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym Thtot(i) = Thtot(i) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) Shtot(i) = Shtot(i) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) else - Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * US%R_to_kg_m3*GV%Rlay(k) + Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%Rlay(k) endif endif ; enddo enddo ; endif @@ -1590,7 +1590,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), & - dR_dT, dR_dS, is-G%IsdB+1, ie-is+1, tv%eqn_of_state) + dR_dT, dR_dS, is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=is,ie ; if (do_i(i)) then @@ -1613,7 +1613,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) + Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif htot(i) = htot(i) + Dh @@ -1629,7 +1629,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym else ! Use Rlay as the density variable. Rhtot = 0.0 do k=1,nz-1 - Rlay = US%R_to_kg_m3*GV%Rlay(k) ; Rlb = US%R_to_kg_m3*GV%Rlay(k+1) + Rlay = GV%Rlay(k) ; Rlb = GV%Rlay(k+1) oldfn = Rlay*htot(i) - Rhtot(i) if (oldfn >= ustarsq) exit @@ -1638,13 +1638,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) + Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) endif htot(i) = htot(i) + Dh Rhtot = Rhtot + Rlay*Dh enddo - if (US%R_to_kg_m3*GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & htot(i) = htot(i) + h_at_vel(i,nz) endif ! use_EOS From ac329dba54f92f3603aa4d5b9586da7d74ac3f30 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 03:44:37 -0400 Subject: [PATCH 095/259] Rescaled density units in MOM_set_diffusivity Rescaled density units in MOM_set_diffusivity for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_set_diffusivity.F90 | 146 +++++++++--------- 1 file changed, 72 insertions(+), 74 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index de312ce1c0..6e453138fb 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -87,10 +87,10 @@ module MOM_set_diffusivity logical :: limit_dissipation !< If enabled, dissipation is limited to be larger !! than the following: - real :: dissip_min !< Minimum dissipation [kg Z2 m-3 T-3 ~> W m-3] - real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [kg Z2 m-3 T-3 ~> W m-3] - real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [kg Z2 m-3 T-2 ~> J m-3] - real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [kg Z2 m-3 T-1 ~> J s m-3] + real :: dissip_min !< Minimum dissipation [R Z2 T-3 ~> W m-3] + real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [R Z2 T-3 ~> W m-3] + real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [R Z2 T-2 ~> J m-3] + real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [R Z2 T-1 ~> J s m-3] real :: dissip_Kd_min !< Minimum Kd [Z2 T-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 real :: TKE_itide_max !< maximum internal tide conversion [W m-2] @@ -175,7 +175,7 @@ module MOM_set_diffusivity N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 T-1 ~> m2 s-1] Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [kg Z3 m-3 T-3 ~> W m-2] + Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] KT_extra => NULL(), & !< double diffusion diffusivity for temp [Z2 T-1 ~> m2 s-1]. KS_extra => NULL() !< double diffusion diffusivity for saln [Z2 T-1 ~> m2 s-1]. @@ -253,12 +253,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, real, dimension(SZI_(G),SZK_(G)+1) :: & N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] - dRho_int, & !< locally ref potential density difference across interfaces [kg m-3] + dRho_int, & !< locally ref potential density difference across interfaces [R ~> kg m-3] KT_extra, & !< double difusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] KS_extra !< double difusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] - real :: I_Rho0 ! inverse of Boussinesq density [m3 kg-1] - real :: dissip ! local variable for dissipation calculations [Z2 kg m-3 T-3 ~> W m-3] + real :: dissip ! local variable for dissipation calculations [Z2 R T-3 ~> W m-3] real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] logical :: use_EOS ! If true, compute density from T/S using equation of state. @@ -279,9 +278,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& "Module must be initialized before it is used.") - I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) - ! ### Dimensional parameters if (CS%answers_2018) then + ! These hard-coded dimensional parameters are being replaced. kappa_dt_fill = US%m_to_Z**2 * 1.e-3 * 7200. else kappa_dt_fill = CS%Kd_smooth * dt_in_T @@ -509,7 +507,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri Kd_lay(i,j,k) = max(Kd_lay(i,j,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (US%R_to_kg_m3*GV%Rho0 * (N2_lay(i,k) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2)))) enddo ; enddo if (present(Kd_int)) then ; do K=2,nz ; do i=is,ie @@ -517,13 +515,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri Kd_int(i,j,K) = max(Kd_int(i,j,K) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (US%R_to_kg_m3*GV%Rho0 * (N2_int(i,K) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2)))) enddo ; enddo ; endif endif if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = US%R_to_kg_m3*GV%Rho0 * Kd_lay(i,j,k) * N2_lay(i,k) * & + dd%Kd_Work(i,j,k) = GV%Rho0 * Kd_lay(i,j,k) * N2_lay(i,k) * & GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 enddo ; enddo endif @@ -634,7 +632,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available !! thermodynamic fields. real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: dRho_int !< Change in locally referenced potential density - !! across each interface [kg m-3]. + !! across each interface [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. integer, intent(in) :: j !< j-index of row to work on @@ -657,7 +655,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & dsp1_ds, & ! inverse coordinate variable (sigma-2) difference ! across an interface times the difference across the ! interface above it [nondim] - rho_0, & ! Layer potential densities relative to surface pressure [kg m-3] + rho_0, & ! Layer potential densities relative to surface pressure [R ~> kg m-3] maxEnt ! maxEnt is the maximum value of entrainment from below (with ! compensating entrainment from above to keep the layer ! density from changing) that will not deplete all of the @@ -668,17 +666,17 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & mFkb, & ! total thickness in the mixed and buffer layers ! times ds_dsp1 [Z ~> m]. p_ref, & ! array of tv%P_Ref pressures - Rcv_kmb, & ! coordinate density in the lowest buffer layer + Rcv_kmb, & ! coordinate density in the lowest buffer layer [R ~> kg m-3] p_0 ! An array of 0 pressures real :: dh_max ! maximum amount of entrainment a layer could ! undergo before entraining all fluid in the layers ! above or below [Z ~> m]. - real :: dRho_lay ! density change across a layer [kg m-3] + real :: dRho_lay ! density change across a layer [R ~> kg m-3] real :: Omega2 ! rotation rate squared [T-2 ~> s-2] - real :: G_Rho0 ! gravitation accel divided by Bouss ref density [Z m3 T-2 kg-1 -> m4 s-2 kg-1] - real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z m3 T-2 kg-1 -> m4 s-2 kg-1] - real :: I_Rho0 ! inverse of Boussinesq reference density [m3 kg-1] + real :: G_Rho0 ! gravitation accel divided by Bouss ref density [Z T-2 R-1 -> m4 s-2 kg-1] + real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z T-2 R-1 -> m4 s-2 kg-1] + real :: I_Rho0 ! inverse of Boussinesq reference density [R-1 ~> m3 kg-1] real :: I_dt ! 1/dt [T-1] real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] real :: hN2pO2 ! h (N^2 + Omega^2), in [m3 T-2 Z-2 ~> m s-2]. @@ -690,9 +688,9 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & I_dt = 1.0 / dt Omega2 = CS%omega**2 H_neglect = GV%H_subroundoff - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) if (CS%answers_2018) then - I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) + I_Rho0 = 1.0 / (GV%Rho0) G_IRho0 = (US%L_to_Z**2 * GV%g_Earth) * I_Rho0 else G_IRho0 = G_Rho0 @@ -719,16 +717,16 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie ; p_0(i) = 0.0 ; p_ref(i) = tv%P_Ref ; enddo do k=1,nz call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), & - is, ie-is+1, tv%eqn_of_state) + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, & - is, ie-is+1, tv%eqn_of_state) + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) kb_min = kmb+1 do i=is,ie ! Determine the next denser layer than the buffer layer in the ! coordinate density (sigma-2). - do k=kmb+1,nz-1 ; if (Rcv_kmb(i) <= US%R_to_kg_m3*GV%Rlay(k)) exit ; enddo + do k=kmb+1,nz-1 ; if (Rcv_kmb(i) <= GV%Rlay(k)) exit ; enddo kb(i) = k ! Backtrack, in case there are massive layers above that are stable @@ -859,7 +857,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: dRho_int !< Change in locally referenced potential density - !! across each interface [kg m-3]. + !! across each interface [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: N2_int !< The squared buoyancy frequency at the interfaces [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(G)), & @@ -867,15 +865,15 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & - dRho_int_unfilt, & ! unfiltered density differences across interfaces - dRho_dT, & ! partial derivative of density wrt temp [kg m-3 degC-1] - dRho_dS ! partial derivative of density wrt saln [kg m-3 ppt-1] + dRho_int_unfilt, & ! unfiltered density differences across interfaces [R ~> kg m-3] + dRho_dT, & ! partial derivative of density wrt temp [R degC-1 ~> kg m-3 degC-1] + dRho_dS ! partial derivative of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G)) :: & pres, & ! pressure at each interface [Pa] Temp_int, & ! temperature at each interface [degC] Salin_int, & ! salinity at each interface [ppt] - drho_bot, & + drho_bot, & ! A density difference [R ~> kg m-3] h_amp, & ! The topographic roughness amplitude [Z ~> m]. hb, & ! The thickness of the bottom layer [Z ~> m]. z_from_bot ! The hieght above the bottom [Z ~> m]. @@ -883,14 +881,14 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real :: Rml_base ! density of the deepest variable density layer real :: dz_int ! thickness associated with an interface [Z ~> m]. real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density - ! times some unit conversion factors [Z m3 T-2 kg-1 ~> m4 s-2 kg-1]. + ! times some unit conversion factors [Z T-2 R-1 ~> m4 s-2 kg-1]. real :: H_neglect ! negligibly small thickness, in the same units as h. logical :: do_i(SZI_(G)), do_any integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -911,7 +909,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:,K), dRho_dS(:,K), is, ie-is+1, tv%eqn_of_state) + dRho_dT(:,K), dRho_dS(:,K), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) @@ -921,7 +919,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo else do K=2,nz ; do i=is,ie - dRho_int(i,K) = US%R_to_kg_m3*GV%Rlay(k) - US%R_to_kg_m3*GV%Rlay(k-1) + dRho_int(i,K) = GV%Rlay(k) - GV%Rlay(k-1) enddo ; enddo endif @@ -957,13 +955,13 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above hb(i) = hb(i) + dz_int - dRho_bot(i) = dRho_bot(i) + dRho_int(i,K) + drho_bot(i) = drho_bot(i) + dRho_int(i,K) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) - dRho_bot(i) = dRho_bot(i) + dRho_int(i,K-1) + drho_bot(i) = drho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. else @@ -975,7 +973,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & do i=is,ie if (hb(i) > 0.0) then - N2_bot(i) = (G_Rho0 * dRho_bot(i)) / hb(i) + N2_bot(i) = (G_Rho0 * drho_bot(i)) / hb(i) else ; N2_bot(i) = 0.0 ; endif z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) do_i(i) = (G%mask2dT(i,j) > 0.5) @@ -1039,14 +1037,14 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) !! diffusivity for saln [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G)) :: & - dRho_dT, & ! partial derivatives of density wrt temp [kg m-3 degC-1] - dRho_dS, & ! partial derivatives of density wrt saln [kg m-3 ppt-1] + dRho_dT, & ! partial derivatives of density wrt temp [R degC-1 ~> kg m-3 degC-1] + dRho_dS, & ! partial derivatives of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] pres, & ! pressure at each interface [Pa] Temp_int, & ! temperature at interfaces [degC] Salin_int ! Salinity at interfaces [ppt] - real :: alpha_dT ! density difference between layers due to temp diffs [kg m-3] - real :: beta_dS ! density difference between layers due to saln diffs [kg m-3] + real :: alpha_dT ! density difference between layers due to temp diffs [R ~> kg m-3] + real :: beta_dS ! density difference between layers due to saln diffs [R ~> kg m-3] real :: Rrho ! vertical density ratio [nondim] real :: diff_dd ! factor for double-diffusion [nondim] @@ -1070,7 +1068,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) Salin_Int(i) = 0.5 * (S_f(i,j,k-1) + S_f(i,j,k)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state) + dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie alpha_dT = -1.0*dRho_dT(i) * (T_f(i,j,k-1) - T_f(i,j,k)) @@ -1137,14 +1135,14 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! This routine adds diffusion sustained by flow energy extracted by bottom drag. real, dimension(SZK_(G)+1) :: & - Rint ! coordinate density of an interface [kg m-3] + Rint ! coordinate density of an interface [R ~> kg m-3] real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the ! integrated thickness in the BBL [Z ~> m]. - rho_htot, & ! running integral with depth of density [Z kg m-3 ~> kg m-2] + rho_htot, & ! running integral with depth of density [Z R ~> kg m-2] gh_sum_top, & ! BBL value of g'h that can be supported by - ! the local ustar, times R0_g [kg m-2] - Rho_top, & ! density at top of the BBL [kg m-3] + ! the local ustar, times R0_g [R ~> kg m-2] + Rho_top, & ! density at top of the BBL [R ~> kg m-3] TKE, & ! turbulent kinetic energy available to drive ! bottom-boundary layer mixing in a layer [Z3 T-3 ~> m3 s-3] I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. @@ -1152,12 +1150,12 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & real :: TKE_to_layer ! TKE used to drive mixing in a layer [Z3 T-3 ~> m3 s-3] real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [Z3 T-3 ~> m3 s-3] real :: TKE_here ! TKE that goes into mixing in this layer [Z3 T-3 ~> m3 s-3] - real :: dRl, dRbot ! temporaries holding density differences [kg m-3] + real :: dRl, dRbot ! temporaries holding density differences [R ~> kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: R0_g ! Rho0 / G_Earth [kg T2 Z-1 m-4 ~> kg s2 m-5] - real :: I_rho0 ! 1 / RHO0 [m3 kg-1] + real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 m-1 ~> kg s2 m-5] + real :: I_rho0 ! 1 / RHO0 [R-1 ~> m3 kg-1] real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 T-1 ~> m2 s-1]. logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this @@ -1177,10 +1175,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE_Ray = 0.0 ; Rayleigh_drag = .false. if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) - R0_g = US%R_to_kg_m3*GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) + I_Rho0 = 1.0 / (GV%Rho0) + R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) - do K=2,nz ; Rint(K) = 0.5*(US%R_to_kg_m3*GV%Rlay(k-1)+US%R_to_kg_m3*GV%Rlay(k)) ; enddo + do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo kb_min = max(GV%nk_rho_varies+1,2) @@ -1204,7 +1202,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & - TKE(i) = TKE(i) + (US%T_to_s**3 * US%m_to_Z**3 * fluxes%TKE_tidal(i,j)) * I_Rho0 * & + TKE(i) = TKE(i) + (US%kg_m3_to_R * US%T_to_s**3 * US%m_to_Z**3 * fluxes%TKE_tidal(i,j)) * I_Rho0 * & (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following @@ -1216,16 +1214,16 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & do_i(i) = (G%mask2dT(i,j) > 0.5) htot(i) = GV%H_to_Z*h(i,j,nz) - rho_htot(i) = US%R_to_kg_m3*GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) - Rho_top(i) = US%R_to_kg_m3*GV%Rlay(1) - if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = US%R_to_kg_m3*GV%Rlay(kb(i)-1) + rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) + Rho_top(i) = GV%Rlay(1) + if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = GV%Rlay(kb(i)-1) enddo do k=nz-1,2,-1 ; domore = .false. do i=is,ie ; if (do_i(i)) then htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - rho_htot(i) = rho_htot(i) + US%R_to_kg_m3*GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) - if (htot(i)*US%R_to_kg_m3*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then + rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) + if (htot(i)*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then ! The top of the mixing is in the interface atop the current layer. Rho_top(i) = (rho_htot(i) - gh_sum_top(i)) / htot(i) do_i(i) = .false. @@ -1256,7 +1254,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & else dRl = Rint(K+1) - Rint(K) ; dRbot = Rint(K+1) - Rho_top(i) TKE_to_layer = TKE(i) * dRl * & - (3.0*dRbot*(Rint(K) - Rho_top(i)) + dRl**2) / dRbot**3 + (3.0*dRbot*(Rint(K) - Rho_top(i)) + dRl**2) / (dRbot**3) endif else ; TKE_to_layer = 0.0 ; endif @@ -1377,7 +1375,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & real :: Kd_wall ! Law of the wall diffusivity [Z2 T-1 ~> m2 s-1]. real :: Kd_lower ! diffusivity for lower interface [Z2 T-1 ~> m2 s-1] real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. - real :: I_Rho0 ! 1 / rho0 + real :: I_Rho0 ! 1 / rho0 [R-1 ~> m3 kg-1] real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. @@ -1394,7 +1392,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Determine whether to add Rayleigh drag contribution to TKE Rayleigh_drag = .false. if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) + I_Rho0 = 1.0 / (GV%Rho0) cdrag_sqrt = sqrt(CS%cdrag) do i=G%isc,G%iec ! Developed in single-column mode @@ -1423,7 +1421,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! Add in tidal dissipation energy at the bottom [m3 s-3]. ! Note that TKE_tidal is in [W m-2]. if (associated(fluxes%TKE_tidal)) & - TKE_column = TKE_column + US%m_to_Z**3*US%T_to_s**3 * fluxes%TKE_tidal(i,j) * I_Rho0 + TKE_column = TKE_column + US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 * fluxes%TKE_tidal(i,j) * I_Rho0 TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column @@ -1792,15 +1790,15 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) !! it [nondim] real, dimension(SZI_(G),SZK_(G)), & optional, intent(in) :: rho_0 !< Layer potential densities relative to - !! surface press [kg m-3]. + !! surface press [R ~> kg m-3]. ! Local variables - real :: g_R0 ! g_R0 is a rescaled version of g/Rho [m3 L2 Z-1 kg-1 T-2 ~> m4 kg-1 s-2] + real :: g_R0 ! g_R0 is a rescaled version of g/Rho [L2 Z-1 R-1 T-2 ~> m4 kg-1 s-2] real :: eps, tmp ! nondimensional temproray variables real :: a(SZK_(G)), a_0(SZK_(G)) ! nondimensional temporary variables real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures - real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers [kg m-3] - real :: I_Drho ! temporary variable [m3 kg-1] + real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] + real :: I_Drho ! temporary variable [R-1 ~> m3 kg-1] integer :: i, k, k3, is, ie, nz, kmb is = G%isc ; ie = G%iec ; nz = G%ke @@ -1818,13 +1816,13 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) enddo if (CS%bulkmixedlayer) then - g_R0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_R0 = GV%g_Earth / (GV%Rho0) kmb = GV%nk_rho_varies eps = 0.1 do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo do k=1,kmb call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), & - is, ie-is+1, tv%eqn_of_state) + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo do i=is,ie if (kb(i) <= nz-1) then @@ -1835,7 +1833,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) I_Drho = g_R0 / GV%g_prime(k+1) ! The indexing convention for a is appropriate for the interfaces. do k3=1,kmb - a(k3+1) = (US%R_to_kg_m3*GV%Rlay(k) - Rcv(i,k3)) * I_Drho + a(k3+1) = (GV%Rlay(k) - Rcv(i,k3)) * I_Drho enddo if ((present(rho_0)) .and. (a(kmb+1) < 2.0*eps*ds_dsp1(i,k))) then ! If the buffer layer nearly matches the density of the layer below in the @@ -2102,18 +2100,18 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "DISSIPATION_MIN", CS%dissip_min, & "The minimum dissipation by which to determine a lower "//& "bound of Kd (a floor).", units="W m-3", default=0.0, & - scale=US%m2_s_to_Z2_T*(US%T_to_s**2)) + scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N0", CS%dissip_N0, & "The intercept when N=0 of the N-dependent expression "//& "used to set a minimum dissipation by which to determine "//& "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & units="W m-3", default=0.0, & - scale=US%m2_s_to_Z2_T*(US%T_to_s**2)) + scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N1", CS%dissip_N1, & "The coefficient multiplying N, following Gargett, used to "//& "set a minimum dissipation by which to determine a lower "//& "bound of Kd (a floor): B in eps_min = A + B*N", & - units="J m-3", default=0.0, scale=US%m2_s_to_Z2_T*US%T_to_s) + units="J m-3", default=0.0, scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*US%T_to_s) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) @@ -2122,7 +2120,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) CS%dissip_N2 = 0.0 if (CS%FluxRi_max > 0.0) & - CS%dissip_N2 = CS%dissip_Kd_min * US%R_to_kg_m3*GV%Rho0 / CS%FluxRi_max + CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', & @@ -2133,7 +2131,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%tm_csp%Lowmode_itidal_dissipation) then CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & - 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%Z_to_m**3*US%s_to_T**3) + 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & From 7f8b55b695da6d5b65d527ca9da21c64b9ce3722 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 08:49:37 -0400 Subject: [PATCH 096/259] Rescaled density units in MOM_kappa_shear Rescaled density units in MOM_kappa_shear for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_kappa_shear.F90 | 23 ++++++++----------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 3cc1e3b34d..d55ce8c9c8 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -130,7 +130,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. - T_2d, S_2d, rho_2d ! 2-D versions of T, S, and rho. + T_2d, S_2d, rho_2d ! 2-D versions of T [degC], S [ppt], and rho [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)+1) :: & kappa_2d, & ! 2-D version of kappa_io [Z2 T-1 ~> m2 s-1]. tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. @@ -194,7 +194,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & if (use_temperature) then ; do k=1,nz ; do i=is,ie T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) enddo ; enddo ; else ; do k=1,nz ; do i=is,ie - rho_2d(i,k) = US%R_to_kg_m3*GV%Rlay(k) ! Could be tv%Rho(i,j,k) ? + rho_2d(i,k) = GV%Rlay(k) ! Could be tv%Rho(i,j,k) ? enddo ; enddo ; endif if (.not.new_kappa) then ; do K=1,nz+1 ; do i=is,ie kappa_2d(i,K) = kappa_io(i,j,K) @@ -396,7 +396,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ real, dimension(SZIB_(G),SZK_(GV)) :: & h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. - T_2d, S_2d, rho_2d ! 2-D versions of T, S, and rho. + T_2d, S_2d, rho_2d ! 2-D versions of T [degC], S [ppt], and rho [R ~> kg m-3]. real, dimension(SZIB_(G),SZK_(GV)+1,2) :: & kappa_2d ! Quasi 2-D versions of kappa_io [Z2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G),SZK_(GV)+1) :: & @@ -492,7 +492,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ! (h(i+1,j,k)**2 + h(i,j+1,k)**2))*GV%H_to_Z * I_hwt enddo ; enddo if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB - rho_2d(I,k) = US%R_to_kg_m3*GV%Rlay(k) + rho_2d(I,k) = GV%Rlay(k) enddo ; enddo ; endif if (.not.new_kappa) then ; do K=1,nz+1 ; do I=IsB,IeB kappa_2d(I,K,J2) = kv_io(I,J,K) * I_Prandtl @@ -744,8 +744,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & real :: bd1 ! A term in the denominator of b1. real :: d1 ! 1 - c1 in the tridiagonal equations. real :: gR0 ! A conversion factor from Z to Pa equal to Rho_0 times g - ! [kg m-1 Z-1 s-2 ~> kg m-2 s-2]. - real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z m3 kg-1 T-2 ~> m4 kg-1 s-2]. + ! [Pa Z-1 = kg m-1 s-2 Z-1 ~> kg m-2 s-2]. + real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> 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 @@ -761,8 +761,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & real :: dt_inc ! An increment to dt_test that is being tested [T ~> s]. real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. - logical :: valid_dt ! If true, all levels so far exhibit acceptably small - ! changes in k_src. + 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. @@ -793,7 +792,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & Ri_crit = CS%Rino_crit gR0 = GV%z_to_H*GV%H_to_Pa - g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) + g_R0 = (US%L_to_Z**2 * 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 ? @@ -884,11 +883,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & 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 + dbuoy_dS, 2, nzc-1, tv%eqn_of_state, scale=-g_R0*US%kg_m3_to_R) else do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif From af57dab7ef0bbb6592de99050a0ad8974f140c0d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 08:50:43 -0400 Subject: [PATCH 097/259] Rescaled density units in MOM_internal_tide_input Rescaled density units in MOM_internal_tide_input for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_internal_tide_input.F90 | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 36066a20fb..25462d0cb6 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -37,12 +37,12 @@ module MOM_int_tide_input type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. real :: TKE_itide_max !< Maximum Internal tide conversion - !! available to mix above the BBL [W m-2] + !! available to mix above the BBL [R m3 s-3 ~> W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [Z2 T-1 ~> m2 s-1]. real, allocatable, dimension(:,:) :: TKE_itidal_coef - !< The time-invariant field that enters the TKE_itidal input calculation [J m-2]. + !< The time-invariant field that enters the TKE_itidal input calculation [R m3 s-2 ~> J m-2]. character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site @@ -120,7 +120,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * US%s_to_T*sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) + itide%TKE_itidal_input(i,j) = US%R_to_kg_m3*min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) enddo ; enddo if (CS%int_tide_source_test) then @@ -167,25 +167,25 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) !! ocean bottom [s-2]. ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & - dRho_int ! The unfiltered density differences across interfaces. + dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. real, dimension(SZI_(G)) :: & pres, & ! The pressure at each interface [Pa]. Temp_int, & ! The temperature at each interface [degC]. Salin_int, & ! The salinity at each interface [ppt]. - drho_bot, & + drho_bot, & ! The density difference at the bottom of a layer [R ~> kg m-3] h_amp, & ! The amplitude of topographic roughness [Z ~> m]. hb, & ! The depth below a layer [Z ~> m]. z_from_bot, & ! The height of a layer center above the bottom [Z ~> m]. - dRho_dT, & ! The partial derivatives of density with temperature and - dRho_dS ! salinity [kg m-3 degC-1] and [kg m-3 ppt-1]. + dRho_dT, & ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + dRho_dS ! The partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: dz_int ! The thickness associated with an interface [Z ~> m]. real :: G_Rho0 ! The gravitation acceleration divided by the Boussinesq - ! density [Z m3 T-2 kg-1 ~> m4 s-2 kg-1]. + ! density [Z T-2 R-1 ~> m4 s-2 kg-1]. logical :: do_i(SZI_(G)), do_any integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) + G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / (GV%Rho0) ! Find the (limited) density jump across each interface. do i=is,ie @@ -211,7 +211,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state) + dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) @@ -219,7 +219,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) enddo else do K=2,nz ; do i=is,ie - dRho_int(i,K) = US%R_to_kg_m3*(GV%Rlay(k) - GV%Rlay(k-1)) + dRho_int(i,K) = (GV%Rlay(k) - GV%Rlay(k-1)) enddo ; enddo endif @@ -350,7 +350,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3) + units="W m-2", default=1.0e3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -403,7 +403,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) itide%h2(i,j) = min((max_frac_rough*G%bathyT(i,j))**2, itide%h2(i,j)) ! Compute the fixed part of internal tidal forcing; units are [J m-2] here. - CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*US%R_to_kg_m3*GV%Rho0*& + CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& kappa_itides * US%Z_to_m**2*itide%h2(i,j) * itide%tideamp(i,j)**2 enddo ; enddo From 3fe1c7bb05a2e37406d636421d9bd68fddb2e57f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 08:51:26 -0400 Subject: [PATCH 098/259] Rescaled density units in diagnoseMLDbyDensityDiff Rescaled density units in diagnoseMLDbyDensityDifference in MOM_diabatic_aux for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_diabatic_aux.F90 | 25 +++++++++++-------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index b50011efed..0158f8e274 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -728,29 +728,30 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, !! or 50 m if missing [Z ~> m] ! Local variables - real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [kg m-3]. + real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [Pa]. real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [degC]. real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [ppt]. - real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [kg m-3]. + real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. real, dimension(SZI_(G)) :: dK, dKm1 ! Depths [Z ~> m]. - real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixedlayer depth [kg m-3]. + real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixedlayer depth [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 ! have been stored already. - real :: gE_Rho0 ! The gravitational acceleration divided by a mean density [Z m3 T-2 kg-1 ~> m4 s-2 kg-1]. + real :: gE_Rho0 ! The gravitational acceleration divided by a mean density [Z T-2 R-1 ~> m4 s-2 kg-1]. real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> m]. + real :: aFac ! A nondimensional factor [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ - real :: aFac, ddRho id_N2 = -1 ; if (PRESENT(id_N2subML)) id_N2 = id_N2subML id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq - gE_rho0 = US%L_to_Z**2*GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + gE_rho0 = US%L_to_Z**2*GV%g_Earth / (GV%Rho0) dH_subML = 50.*GV%m_to_H ; if (present(dz_subML)) dH_subML = GV%Z_to_H*dz_subML is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -758,7 +759,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, pRef_MLD(:) = 0.0 do j=js,je do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is, ie-is+1, tv%eqn_of_state) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie deltaRhoAtK(i) = 0. MLD(i,j) = 0. @@ -799,7 +801,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Mixed-layer depth, using sigma-0 (surface reference pressure) do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, is, ie-is+1, tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, is, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R) do i = is, ie deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) @@ -822,8 +825,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) ! N2_region_set(i) = .true. ! endif - call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, is, ie-is+1, tv%eqn_of_state) - call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, is, ie-is+1, tv%eqn_of_state) + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, is, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, is, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo From 87a2c4dc6cd10b60dcd41c2d5fac1898a84fff9e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 08:52:22 -0400 Subject: [PATCH 099/259] Rescaled density units in MOM_tidal_mixing Rescaled density units in MOM_tidal_mixing for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_tidal_mixing.F90 | 58 ++++++++++--------- 1 file changed, 31 insertions(+), 27 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index aa158581fc..887cc6d067 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -45,9 +45,9 @@ module MOM_tidal_mixing Kd_itidal => NULL(),& !< internal tide diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. Fl_itidal => NULL(),& !< vertical flux of tidal turbulent dissipation [Z3 T-3 ~> m3 s-3] Kd_Niku => NULL(),& !< lee-wave diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. - Kd_Niku_work => NULL(),& !< layer integrated work by lee-wave driven mixing [kg Z3 m-3 T-3 ~> W m-2] - Kd_Itidal_Work => NULL(),& !< layer integrated work by int tide driven mixing [kg Z3 m-3 T-3 ~> W m-2] - Kd_Lowmode_Work => NULL(),& !< layer integrated work by low mode driven mixing [kg Z3 m-3 T-3 ~> W m-2] + Kd_Niku_work => NULL(),& !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] + Kd_Itidal_Work => NULL(),& !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] + Kd_Lowmode_Work => NULL(),& !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] N2_int => NULL(),& !< Bouyancy frequency squared at interfaces [s-2] vert_dep_3d => NULL(),& !< The 3-d mixing energy deposition [W m-3] Schmittner_coeff_3d => NULL() !< The coefficient in the Schmittner et al mixing scheme, in UNITS? @@ -58,7 +58,7 @@ module MOM_tidal_mixing real, pointer, dimension(:,:,:) :: Fl_lowmode => NULL() !< vertical flux of tidal turbulent !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] real, pointer, dimension(:,:) :: & - TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [kg Z3 m-3 T-3 ~> W m-2] + TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] N2_bot => NULL(),& !< bottom squared buoyancy frequency [T-2 ~> s-2] N2_meanz => NULL(),& !< vertically averaged buoyancy frequency [T-2 ~> s-2] Polzin_decay_scale_scaled => NULL(),& !< vertical scale of decay for tidal dissipation @@ -108,7 +108,7 @@ module MOM_tidal_mixing !! et al. (2002) and Simmons et al. (2004). real :: Nu_Polzin !< The non-dimensional constant used in Polzin form of - !! the vertical scale of decay of tidal dissipation + !! the vertical scale of decay of tidal dissipation [nondim] real :: Nbotref_Polzin !< Reference value for the buoyancy frequency at the !! ocean bottom used in Polzin formulation of the @@ -121,7 +121,7 @@ module MOM_tidal_mixing real :: Polzin_min_decay_scale !< minimum decay scale of the tidal dissipation !! profile in Polzin formulation [Z ~> m]. - real :: TKE_itide_max !< maximum internal tide conversion [kg Z3 m-3 T-3 ~> W m-2] + real :: TKE_itide_max !< maximum internal tide conversion [R Z3 T-3 ~> W m-2] !! available to mix above the BBL real :: utide !< constant tidal amplitude [Z T-1 ~> m s-1] if READ_TIDEAMP is false. @@ -145,9 +145,9 @@ module MOM_tidal_mixing ! Data containers real, pointer, dimension(:,:) :: TKE_Niku => NULL() !< Lee wave driven Turbulent Kinetic Energy input - !! [kg Z3 m-3 T-3 ~> W m-2] + !! [R Z3 T-3 ~> W m-2] real, pointer, dimension(:,:) :: TKE_itidal => NULL() !< The internal Turbulent Kinetic Energy input divided - !! by the bottom stratfication [kg Z3 m-3 T-2 ~> J m-2]. + !! by the bottom stratfication [R Z3 T-2 ~> J m-2]. real, pointer, dimension(:,:) :: Nb => NULL() !< The near bottom buoyancy frequency [T-1 ~> s-1]. real, pointer, dimension(:,:) :: mask_itidal => NULL() !< A mask of where internal tide energy is input real, pointer, dimension(:,:) :: h2 => NULL() !< Squared bottom depth variance [m2]. @@ -433,7 +433,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%m_to_Z**3*US%T_to_s**3) + units="W m-2", default=1.0e3, scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -479,8 +479,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) utide = CS%tideamp(i,j) ! Compute the fixed part of internal tidal forcing. - ! The units here are [kg Z3 m-3 T-2 ~> J m-2 = kg s-2] here. - CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * US%R_to_kg_m3*GV%Rho0 * & + ! The units here are [R Z3 T-2 ~> J m-2 = kg s-2] here. + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%Rho0 * & CS%kappa_itides * CS%h2(i,j) * utide*utide enddo ; enddo @@ -502,7 +502,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) filename) call safe_alloc_ptr(CS%TKE_Niku,is,ie,js,je) ; CS%TKE_Niku(:,:) = 0.0 call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja - scale=US%m_to_Z**3*US%T_to_s**3) + scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) CS%TKE_Niku(:,:) = Niku_scale * CS%TKE_Niku(:,:) call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & @@ -596,7 +596,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) else CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'Internal Tide Driven Turbulent Kinetic Energy', & + 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) CS%id_Nb = register_diag_field('ocean_model','Nb',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) @@ -628,20 +629,23 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) 'Buoyancy frequency squared averaged over the water column', 's-2', conversion=US%s_to_T**2) CS%id_Kd_Itidal_Work = register_diag_field('ocean_model','Kd_Itidal_Work',diag%axesTL,Time, & - 'Work done by Internal Tide Diapycnal Mixing', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'Work done by Internal Tide Diapycnal Mixing', & + 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Niku_Work = register_diag_field('ocean_model','Kd_Nikurashin_Work',diag%axesTL,Time, & - 'Work done by Nikurashin Lee Wave Drag Scheme', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'Work done by Nikurashin Lee Wave Drag Scheme', & + 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Lowmode_Work = register_diag_field('ocean_model','Kd_Lowmode_Work',diag%axesTL,Time, & 'Work done by Internal Tide Diapycnal Mixing (low modes)', & - 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) if (CS%Lee_wave_dissipation) then CS%id_TKE_leewave = register_diag_field('ocean_model','TKE_leewave',diag%axesT1,Time, & - 'Lee wave Driven Turbulent Kinetic Energy', 'W m-2', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'Lee wave Driven Turbulent Kinetic Energy', & + 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & - 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) endif endif ! S%use_CVMix_tidal endif @@ -992,7 +996,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, z_from_bot, & ! distance from bottom [Z ~> m]. z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. - real :: I_rho0 ! 1 / RHO0 [m3 kg-1] + real :: I_rho0 ! Inverse of the Boussinesq reference density, i.e. 1 / RHO0 [R-1 ~> m3 kg-1] real :: Kd_add ! diffusivity to add in a layer [Z2 T-1 ~> m2 s-1]. real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] @@ -1003,7 +1007,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3]. real :: z0Ps_denom ! The denominator of the unlimited z0_Polzin_scaled [T-3 ~> s-3]. real :: z0_psl ! temporary variable [Z ~> m]. - real :: TKE_lowmode_tot ! TKE from all low modes [kg Z3 m-3 T-3 ~> W m-2] (BDM) + real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] (BDM) logical :: use_Polzin, use_Simmons character(len=160) :: mesg ! The text of an error message @@ -1021,7 +1025,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) enddo ; enddo - I_Rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) + I_Rho0 = 1.0 / (GV%Rho0) use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09)) .or. & @@ -1255,7 +1259,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, if (k Date: Sat, 28 Sep 2019 08:53:24 -0400 Subject: [PATCH 100/259] +Rescaled density units in MOM_geothermal Rescaled density units in MOM_geothermal for dimensional consistency testing. This required adding a unit_scale_type argument to geothermal_init. All answers are bitwise identical, but a public interface has a new argument. --- .../vertical/MOM_diabatic_driver.F90 | 2 +- .../vertical/MOM_geothermal.F90 | 35 ++++++++++--------- 2 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 728a2b2fa6..4de97fc0ca 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3692,7 +3692,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! initialize the geothermal heating module if (CS%use_geothermal) & - call geothermal_init(Time, G, GV, param_file, diag, CS%geothermal_CSp) + call geothermal_init(Time, G, GV, US, param_file, diag, CS%geothermal_CSp) ! initialize module for internal tide induced mixing if (CS%use_int_tides) then diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index bac7a20313..929e515177 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -25,7 +25,7 @@ module MOM_geothermal type, public :: geothermal_CS ; private real :: dRcv_dT_inplace !< The value of dRcv_dT above which (dRcv_dT is !! negative) the water is heated in place instead - !! of moving upward between layers [kg m-3 degC-1]. + !! of moving upward between layers [R degC-1 ~> kg m-3 degC-1]. real, pointer :: geo_heat(:,:) => NULL() !< The geothermal heat flux [W m-2]. real :: geothermal_thick !< The thickness over which geothermal heating is !! applied [m] (not [H]). @@ -76,20 +76,20 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) real, dimension(SZI_(G)) :: & heat_rem, & ! remaining heat [H degC ~> m degC or kg degC m-2] h_geo_rem, & ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] - Rcv_BL, & ! coordinate density in the deepest variable density layer [kg m-3] + Rcv_BL, & ! coordinate density in the deepest variable density layer [R ~> kg m-3] p_ref ! coordiante densities reference pressure [Pa] real, dimension(2) :: & T2, S2, & ! temp and saln in the present and target layers [degC] and [ppt] - dRcv_dT_, & ! partial derivative of coordinate density wrt temp [kg m-3 degC-1] - dRcv_dS_ ! partial derivative of coordinate density wrt saln [kg m-3 ppt-1] + dRcv_dT_, & ! partial derivative of coordinate density wrt temp [R degC-1 ~> kg m-3 degC-1] + dRcv_dS_ ! partial derivative of coordinate density wrt saln [R ppt-1 ~> kg m-3 ppt-1] real :: Angstrom, H_neglect ! small thicknesses [H ~> m or kg m-2] - real :: Rcv ! coordinate density of present layer [kg m-3] - real :: Rcv_tgt ! coordinate density of target layer [kg m-3] - real :: dRcv ! difference between Rcv and Rcv_tgt [kg m-3] + real :: Rcv ! coordinate density of present layer [R ~> kg m-3] + real :: Rcv_tgt ! coordinate density of target layer [R ~> kg m-3] + real :: dRcv ! difference between Rcv and Rcv_tgt [R ~> kg m-3] real :: dRcv_dT ! partial derivative of coordinate density wrt temp - ! in the present layer [kg m-3 degC-1]; usually negative + ! in the present layer [R degC-1 ~> kg m-3 degC-1]; usually negative real :: h_heated ! thickness that is being heated [H ~> m or kg m-2] real :: heat_avail ! heating available for the present layer [degC H ~> degC m or degC kg m-2] real :: heat_in_place ! heating to warm present layer w/o movement between layers @@ -197,7 +197,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) if (nkmb > 0) then call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), & - Rcv_BL(:), isj, iej-isj+1, tv%eqn_of_state) + Rcv_BL(:), isj, iej-isj+1, tv%eqn_of_state, scale=US%kg_m3_to_R) else Rcv_BL(:) = -1.0 endif @@ -229,25 +229,25 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) ! Simply heat the layer; convective adjustment occurs later ! if necessary. k_tgt = k - elseif ((k==nkmb+1) .or. (US%R_to_kg_m3*GV%Rlay(k-1) < Rcv_BL(i))) then + elseif ((k==nkmb+1) .or. (GV%Rlay(k-1) < Rcv_BL(i))) then ! Add enough heat to match the lowest buffer layer density. k_tgt = nkmb Rcv_tgt = Rcv_BL(i) else ! Add enough heat to match the target density of layer k-1. k_tgt = k-1 - Rcv_tgt = US%R_to_kg_m3*GV%Rlay(k-1) + Rcv_tgt = GV%Rlay(k-1) endif if (k<=nkmb .or. nkmb<=0) then Rcv = 0.0 ; dRcv_dT = 0.0 ! Is this OK? else call calculate_density(tv%T(i,j,k), tv%S(i,j,k), tv%P_Ref, & - Rcv, tv%eqn_of_state) + Rcv, tv%eqn_of_state, scale=US%kg_m3_to_R) T2(1) = tv%T(i,j,k) ; S2(1) = tv%S(i,j,k) T2(2) = tv%T(i,j,k_tgt) ; S2(2) = tv%S(i,j,k_tgt) call calculate_density_derivs(T2(:), S2(:), p_Ref(:), & - dRcv_dT_, dRcv_dS_, 1, 2, tv%eqn_of_state) + dRcv_dT_, dRcv_dS_, 1, 2, tv%eqn_of_state, scale=US%kg_m3_to_R) dRcv_dT = 0.5*(dRcv_dT_(1) + dRcv_dT_(2)) endif @@ -258,13 +258,13 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) elseif (dRcv_dT <= CS%dRcv_dT_inplace) then ! This is the option that usually applies in isopycnal coordinates. heat_in_place = min(heat_avail, max(0.0, h(i,j,k) * & - ((US%R_to_kg_m3*GV%Rlay(k)-Rcv) / dRcv_dT))) + ((GV%Rlay(k)-Rcv) / dRcv_dT))) heat_trans = heat_avail - heat_in_place else ! wt_in_place should go from 0 to 1. wt_in_place = (CS%dRcv_dT_inplace - dRcv_dT) / CS%dRcv_dT_inplace heat_in_place = max(wt_in_place*heat_avail, & - h(i,j,k) * ((US%R_to_kg_m3*GV%Rlay(k)-Rcv) / dRcv_dT) ) + h(i,j,k) * ((GV%Rlay(k)-Rcv) / dRcv_dT) ) heat_trans = heat_avail - heat_in_place endif @@ -373,10 +373,11 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) end subroutine geothermal !> Initialize parameters and allocate memory associated with the geothermal heating module. -subroutine geothermal_init(Time, G, GV, param_file, diag, CS) +subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< Structure used to regulate diagnostic output. @@ -423,7 +424,7 @@ subroutine geothermal_init(Time, G, GV, param_file, diag, CS) "The value of drho_dT above which geothermal heating "//& "simply heats water in place instead of moving it between "//& "isopycnal layers. This must be negative.", & - units="kg m-3 K-1", default=-0.01) + units="kg m-3 K-1", scale=US%kg_m3_to_R, default=-0.01) if (CS%dRcv_dT_inplace >= 0.0) call MOM_error(FATAL, "geothermal_init: "//& "GEOTHERMAL_DRHO_DT_INPLACE must be negative.") From 727199a8c7b2d1098e988ecedda2af9b15cedc35 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 08:57:06 -0400 Subject: [PATCH 101/259] Corrected dimensions in comments Corrected dimensions in comments. All answers are bitwise identical. --- src/initialization/midas_vertmap.F90 | 6 +++--- src/parameterizations/vertical/MOM_entrain_diffusive.F90 | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index a985cf2982..9869877b68 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -561,10 +561,10 @@ end function find_limited_slope !> Find interface positions corresponding to density profile function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps_z) result(zi) real, dimension(:,:,:), & - intent(in) :: rho !< potential density in z-space [kg m-3] + intent(in) :: rho !< potential density in z-space [R ~> kg m-3] real, dimension(size(rho,3)), & intent(in) :: zin !< Input data levels [Z ~> m or m]. - real, dimension(:), intent(in) :: Rb !< target interface densities [kg m-3] + real, dimension(:), intent(in) :: Rb !< target interface densities [R ~> kg m-3] real, dimension(size(rho,1),size(rho,2)), & intent(in) :: depth !< ocean depth [Z ~> m]. real, dimension(size(rho,1),size(rho,2)), & @@ -577,7 +577,7 @@ function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi !< The returned interface, in the same units az zin. ! Local variables - real, dimension(size(rho,1),size(rho,3)) :: rho_ + real, dimension(size(rho,1),size(rho,3)) :: rho_ ! A slice of densities [R ~> kg m-3] real, dimension(size(rho,1)) :: depth_ logical :: unstable integer :: dir diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 967dd31ae9..3942b66f22 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -131,7 +131,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & dS_kb, & ! The reference potential density difference across the ! interface between the buffer layers and layer kb [R ~> kg m-3]. dS_anom_lim, &! The amount by which dS_kb is reduced when limits are - ! applied [kg m-3]. + ! applied [R ~> kg m-3]. I_dSkbp1, & ! The inverse of the potential density difference across the ! interface below layer kb [R-1 ~> m3 kg-1]. dtKd_kb, & ! The diapycnal diffusivity in layer kb times the time step @@ -1627,7 +1627,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! kb, limited to ensure that it is positive and not ! too much bigger than dS_kb or dS_kbp1 [R ~> kg m-3]. ddSkb_dE, ddSlay_dE, & ! The derivatives of dS_kb and dS_Lay with E - ! [kg m-3 H-1 ~> kg m-4 or m-1]. + ! [R H-1 ~> kg m-4 or m-1]. derror_dE, & ! The derivative of err with E [H ~> m or kg m-2]. err, & ! The "error" whose zero is being sought [H2 ~> m2 or kg2 m-4]. E_min, E_max, & ! The minimum and maximum values of E [H ~> m or kg m-2]. @@ -1635,7 +1635,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & real :: err_est ! An estimate of what err will be [H2 ~> m2 or kg2 m-4]. real :: eL ! 1 or 0, depending on whether increases in E lead ! to decreases in the entrainment from below by the - ! deepest buffer layer. + ! deepest buffer layer [nondim]. real :: fa ! Temporary variable used to calculate err [nondim]. real :: fk ! Temporary variable used to calculate err [H2 ~> m2 or kg2 m-4]. real :: fm, fr ! Temporary variables used to calculate err [H ~> m or kg m-2]. From 80b2d990a9d85afeb01a2e4c2720e887d505a4cf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Sep 2019 09:30:29 -0400 Subject: [PATCH 102/259] +Partially rescaled the units of TKE_itidal_input Partially rescaled the units of itide%TKE_itidal_input for dimensional consistency testing. All answers are bitwise identical, but the units of an element of a transparent public type have changed. --- src/parameterizations/lateral/MOM_internal_tides.F90 | 10 +++++----- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 +- .../vertical/MOM_internal_tide_input.F90 | 10 +++++----- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 4f91cd7ea5..3c16ae0e57 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -103,7 +103,7 @@ module MOM_internal_tides logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. real, dimension(:,:,:,:,:), pointer :: En => NULL() - !< The internal wave energy density as a function of (i,j,angle,frequency,mode) + !< The internal wave energy density as a function of (i,j,angle,frequency,mode) [J m-2] real, dimension(:,:,:), pointer :: En_restart => NULL() !< The internal wave energy density as a function of (i,j,angle); temporary for restart real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. @@ -157,7 +157,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables !! (needed for wave structure). real, dimension(SZI_(G),SZJ_(G)), intent(in) :: TKE_itidal_input !< The energy input to the - !! internal waves [W m-2]. + !! internal waves [R m3 s-3 ~> W m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read !! from file [m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [s-1]. @@ -221,7 +221,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & - dt*frac_per_sector*(1-CS%q_itides)*TKE_itidal_input(i,j) + dt*frac_per_sector*(1.0-CS%q_itides)*US%R_to_kg_m3*TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo ; enddo elseif (CS%energized_angle <= CS%nAngle) then frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) @@ -231,7 +231,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & - dt*frac_per_sector**(1-CS%q_itides)*TKE_itidal_input(i,j) + dt*frac_per_sector*(1.0-CS%q_itides)*US%R_to_kg_m3*TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo else call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& @@ -2427,7 +2427,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !Register 2-D energy input into internal tides CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & Time, 'Conversion from barotropic to baroclinic tide, '//& - 'a fraction of which goes into rays', 'W m-2') + 'a fraction of which goes into rays', 'W m-2', conversion=US%R_to_kg_m3) ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', 'W m-2') diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 4de97fc0ca..a9505c6a91 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -283,7 +283,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn_IGW ! baroclinic internal gravity wave speeds real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp - real, dimension(SZI_(G),SZJ_(G)) :: TKE_itidal_input_test ! override of energy input for testing (BDM) +!### real, dimension(SZI_(G),SZJ_(G)) :: TKE_itidal_input_test ! override of energy input for testing (BDM) real :: dt_in_T ! The time step converted to T units [T ~> s] integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 25462d0cb6..89629e0552 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -62,7 +62,7 @@ module MOM_int_tide_input !> This type is used to exchange fields related to the internal tides. type, public :: int_tide_input_type real, allocatable, dimension(:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [W m-2]. + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R m3 s-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. tideamp, & !< The amplitude of the tidal velocities [m s-1]. Nb !< The bottom stratification [s-1]. @@ -120,7 +120,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * US%s_to_T*sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = US%R_to_kg_m3*min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) + itide%TKE_itidal_input(i,j) = min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) enddo ; enddo if (CS%int_tide_source_test) then @@ -131,7 +131,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - itide%TKE_itidal_input(i,j) = 1.0 + itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R endif enddo ; enddo endif @@ -139,7 +139,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (CS%debug) then call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0) + call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, scale=US%R_to_kg_m3) endif if (CS%id_TKE_itidal > 0) call post_data(CS%id_TKE_itidal, itide%TKE_itidal_input, CS%diag) @@ -409,7 +409,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2') + 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2', conversion=US%R_to_kg_m3) CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1') From 68e322bc70a4206dfb1a3cae4d53dc7098d8a078 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 07:29:33 -0400 Subject: [PATCH 103/259] Rescaled density units in MOM_energetic_PBL Rescaled density units in MOM_energetic_PBL for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_energetic_PBL.F90 | 172 +++++++++--------- 1 file changed, 87 insertions(+), 85 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index a99aa7c1e2..5cdc151182 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -165,16 +165,16 @@ module MOM_energetic_PBL real, allocatable, dimension(:,:) :: & ML_depth !< The mixed layer depth determined by active mixing in ePBL [Z ~> m]. - ! These are terms in the mixed layer TKE budget, all in [kg m-3 Z3 T-2 ~> J m-2] = [kg s-2]. + ! These are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2 = kg s-3]. real, allocatable, dimension(:,:) :: & - diag_TKE_wind, & !< The wind source of TKE [kg m-3 Z3 T-3 ~> W m-2]. - diag_TKE_MKE, & !< The resolved KE source of TKE [kg m-3 Z3 T-3 ~> W m-2]. - diag_TKE_conv, & !< The convective source of TKE [kg m-3 Z3 T-3 ~> W m-2]. + diag_TKE_wind, & !< The wind source of TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_MKE, & !< The resolved KE source of TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_conv, & !< The convective source of TKE [R Z3 T-3 ~> W m-2]. diag_TKE_forcing, & !< The TKE sink required to mix surface penetrating shortwave heating - !! [kg m-3 Z3 T-2 ~> W m-2]. - diag_TKE_mech_decay, & !< The decay of mechanical TKE [kg m-3 Z3 T-3 ~> W m-2]. - diag_TKE_conv_decay, & !< The decay of convective TKE [kg m-3 Z3 T-3 ~> W m-2]. - diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [kg m-3 Z3 T-3 ~> W m-2]. + !! [R Z3 T-3 ~> W m-2]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_conv_decay, & !< The decay of convective TKE [R Z3 T-3 ~> W m-2]. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [R Z3 T-3 ~> W m-2]. ! These additional diagnostics are also 2d. MSTAR_MIX, & !< Mstar used in EPBL [nondim] MSTAR_LT, & !< Mstar due to Langmuir turbulence [nondim] @@ -219,7 +219,7 @@ module MOM_energetic_PBL !> A type for conveniently passing around ePBL diagnostics for a column. type, public :: ePBL_column_diags ; private - !>@{ Local column copies of energy change diagnostics, all in [kg m-3 Z3 T-3 ~> W m-2]. + !>@{ Local column copies of energy change diagnostics, all in [R Z3 T-3 ~> W m-2]. real :: dTKE_conv, dTKE_forcing, dTKE_wind, dTKE_mixing real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay !!@} @@ -320,9 +320,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS h_2d, & ! A 2-d slice of the layer thickness [H ~> m or kg m-2]. T_2d, & ! A 2-d slice of the layer temperatures [degC]. S_2d, & ! A 2-d slice of the layer salinities [ppt]. - TKE_forced_2d, & ! A 2-d slice of TKE_forced [kg m-3 Z3 T-2 ~> J m-2]. - dSV_dT_2d, & ! A 2-d slice of dSV_dT [m3 kg-1 degC-1]. - dSV_dS_2d, & ! A 2-d slice of dSV_dS [m3 kg-1 ppt-1]. + TKE_forced_2d, & ! A 2-d slice of TKE_forced [R Z3 T-2 ~> J m-2]. + dSV_dT_2d, & ! A 2-d slice of dSV_dT [R-1 degC-1 ~> m3 kg-1 degC-1]. + dSV_dS_2d, & ! A 2-d slice of dSV_dS [R-1 ppt-1 ~> m3 kg-1 ppt-1]. u_2d, & ! A 2-d slice of the zonal velocity [L T-1 ~> m s-1]. v_2d ! A 2-d slice of the meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK_(GV)+1) :: & @@ -331,9 +331,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS h, & ! The layer thickness [H ~> m or kg m-2]. T0, & ! The initial layer temperatures [degC]. S0, & ! The initial layer salinities [ppt]. - dSV_dT_1d, & ! The partial derivatives of specific volume with temperature [m3 kg-1 degC-1]. - dSV_dS_1d, & ! The partial derivatives of specific volume with salinity [m3 kg-1 ppt-1]. - TKE_forcing, & ! Forcing of the TKE in the layer coming from TKE_forced [kg m-3 Z3 T-2 ~> J m-2]. + dSV_dT_1d, & ! The partial derivatives of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. + dSV_dS_1d, & ! The partial derivatives of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + TKE_forcing, & ! Forcing of the TKE in the layer coming from TKE_forced [R Z3 T-2 ~> J m-2]. u, & ! The zonal velocity [L T-1 ~> m s-1]. v ! The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZK_(GV)+1) :: & @@ -406,8 +406,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do k=1,nz ; do i=is,ie h_2d(i,k) = h_3d(i,j,k) ; u_2d(i,k) = u_3d(i,j,k) ; v_2d(i,k) = v_3d(i,j,k) T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) - TKE_forced_2d(i,k) = TKE_forced(i,j,k) - dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = dSV_dS(i,j,k) + TKE_forced_2d(i,k) = US%kg_m3_to_R*TKE_forced(i,j,k) + dSV_dT_2d(i,k) = US%R_to_kg_m3*dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = US%R_to_kg_m3*dSV_dS(i,j,k) enddo ; enddo ! Determine the initial mech_TKE and conv_PErel, including the energy required @@ -547,12 +547,12 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real, dimension(SZK_(GV)), intent(in) :: dSV_dT !< The partial derivative of in-situ specific !! volume with potential temperature - !! [m3 kg-1 degC-1]. + !! [R-1 degC-1 ~> m3 kg-1 degC-1]. real, dimension(SZK_(GV)), intent(in) :: dSV_dS !< The partial derivative of in-situ specific - !! volume with salinity [m3 kg-1 ppt-1]. + !! volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer - !! [kg m-3 Z3 T-2 ~> J m-2]. + !! [R Z3 T-2 ~> J m-2]. real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1]. real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. @@ -595,15 +595,15 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! mixing. ! Local variables - real, dimension(SZK_(GV)+1) :: & + real, dimension(SZK_(GV)+1) :: & pres_Z, & ! Interface pressures with a rescaling factor to convert interface height - ! movements into changes in column potential energy [kg m-3 Z2 T-2 ~> kg m-1 s-2]. + ! movements into changes in column potential energy [R Z2 T-2 ~> kg m-1 s-2]. hb_hs ! The distance from the bottom over the thickness of the ! water column [nondim]. real :: mech_TKE ! The mechanically generated turbulent kinetic energy - ! available for mixing over a time step [kg m-3 Z3 T-2 ~> J m-2]. + ! available for mixing over a time step [R Z3 T-2 ~> J m-2]. real :: conv_PErel ! The potential energy that has been convectively released - ! during this timestep [kg m-3 Z3 T-2 ~> J m-2]. A portion nstar_FC + ! during this timestep [R Z3 T-2 ~> J m-2]. A portion nstar_FC ! of conv_PErel is available to drive mixing. real :: htot ! The total depth of the layers above an interface [H ~> m or kg m-2]. real :: uhtot ! The depth integrated zonal and meridional velocities in the @@ -617,9 +617,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs dS_to_dColHt, & ! Partial derivative of the total column height with the salinity changes ! within a layer [Z ppt-1 ~> m ppt-1]. dT_to_dPE, & ! Partial derivatives of column potential energy with the temperature - ! changes within a layer, in [kg m-3 Z3 T-2 degC-1 ~> J m-2 degC-1]. + ! changes within a layer, in [R Z3 T-2 degC-1 ~> J m-2 degC-1]. dS_to_dPE, & ! Partial derivatives of column potential energy with the salinity changes - ! within a layer, in [kg m-3 Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + ! within a layer, in [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. dT_to_dColHt_a, & ! Partial derivative of the total column height with the temperature changes ! within a layer, including the implicit effects of mixing with layers higher ! in the water column [Z degC-1 ~> m degC-1]. @@ -628,10 +628,10 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! in the water column [Z ppt-1 ~> m ppt-1]. dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature changes ! within a layer, including the implicit effects of mixing with layers higher - ! in the water column [kg m-3 Z3 T-2 degC-1 ~> J m-2 degC-1]. + ! in the water column [R Z3 T-2 degC-1 ~> J m-2 degC-1]. dS_to_dPE_a, & ! Partial derivative of column potential energy with the salinity changes ! within a layer, including the implicit effects of mixing with layers higher - ! in the water column [kg m-3 Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + ! in the water column [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. c1, & ! c1 is used by the tridiagonal solver [nondim]. Te, & ! Estimated final values of T in the column [degC]. Se, & ! Estimated final values of S in the column [ppt]. @@ -657,12 +657,12 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! in the denominator of b1 in a downward-oriented tridiagonal solver. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: dMass ! The mass per unit area within a layer [Z kg m-3 ~> kg m-2]. - real :: dPres ! The hydrostatic pressure change across a layer [kg m-3 Z2 T-2 ~> kg m-1 s-2 = Pa]. + real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2]. + real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> kg m-1 s-2 = Pa = J m-3]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be ! converted to turbulent kinetic energy if the velocity in ! the layer below an interface were homogenized with all of - ! the water above the interface [kg m-3 Z3 T-2 ~> J m-2]. + ! the water above the interface [R Z3 T-2 ~> J m-2]. real :: MKE2_Hharm ! Twice the inverse of the harmonic mean of the thickness ! of a layer and the thickness of the water above, used in ! the MKE conversion equation [H-1 ~> m-1 or m2 kg-1]. @@ -679,7 +679,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: h_tt_min ! A surface roughness length [H ~> m or kg m-2]. real :: C1_3 ! = 1/3. - real :: I_dtrho ! 1.0 / (dt * Rho0) times conversion factors in [m6 Z-3 kg-1 T2 s-3 ~> m3 kg-1 s-1]. + real :: I_dtrho ! 1.0 / (dt * Rho0) times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1]. ! This is used convert TKE back into ustar^3. real :: vstar ! An in-situ turbulent velocity [Z T-1 ~> m s-1]. real :: mstar_total ! The value of mstar used in ePBL [nondim] @@ -692,8 +692,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: nstar_FC ! The fraction of conv_PErel that can be converted to mixing [nondim]. real :: TKE_reduc ! The fraction by which TKE and other energy fields are ! reduced to support mixing [nondim]. between 0 and 1. - real :: tot_TKE ! The total TKE available to support mixing at interface K [kg m-3 Z3 T-2 ~> J m-2]. - real :: TKE_here ! The total TKE at this point in the algorithm [kg m-3 Z3 T-2 ~> J m-2]. + real :: tot_TKE ! The total TKE available to support mixing at interface K [R Z3 T-2 ~> J m-2]. + real :: TKE_here ! The total TKE at this point in the algorithm [R Z3 T-2 ~> J m-2]. real :: dT_km1_t2 ! A diffusivity-independent term related to the temperature ! change in the layer above the interface [degC]. real :: dS_km1_t2 ! A diffusivity-independent term related to the salinity @@ -704,24 +704,26 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! change in the layer above the interface [ppt H ~> ppt m or ppt kg m-2]. real :: dTe_t2 ! A part of dTe_term [degC H ~> degC m or degC kg m-2]. real :: dSe_t2 ! A part of dSe_term [ppt H ~> ppt m or ppt kg m-2]. - real :: dPE_conv ! The convective change in column potential energy [kg m-3 Z3 T-2 ~> J m-2]. - real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K) [kg m-3 Z3 T-2 ~> J m-2]. - real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [kg m-3 Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real :: dPE_conv ! The convective change in column potential energy [R Z3 T-2 ~> J m-2]. + real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K) [R Z3 T-2 ~> J m-2]. + real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [kg m-3 Z3 T-2 ~> J m-2] - real :: dPEa_dKd_g0 + real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [R Z3 T-2 ~> J m-2] + !### The following might be unused. + real :: dPEa_dKd_g0 ! The derivative of the change in the potential energy of the column above an interface + ! with the diffusivity when the Kd is Kd_guess0 [R Z T-1 ~> J s m-4] real :: Kddt_h_g0 ! The first guess diapycnal diffusivity times a timestep divided ! by the average thicknesses around a layer [H ~> m or kg m-2]. - real :: PE_chg_max ! The maximum PE change for very large values of Kddt_h(K) [kg m-3 Z3 T-2 ~> J m-2]. + real :: PE_chg_max ! The maximum PE change for very large values of Kddt_h(K) [R Z3 T-2 ~> J m-2]. real :: dPEc_dKd_Kd0 ! The partial derivative of PE change with Kddt_h(K) - ! for very small values of Kddt_h(K) [kg m-3 Z3 T-2 H-1 ~> J m-3 or J kg-1]. + ! for very small values of Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real :: PE_chg ! The change in potential energy due to mixing at an - ! interface [kg m-3 Z3 T-2 ~> J m-2], positive for the column increasing + ! interface [R Z3 T-2 ~> J m-2], positive for the column increasing ! in potential energy (i.e., consuming TKE). real :: TKE_left ! The amount of turbulent kinetic energy left for the most - ! recent guess at Kddt_h(K) [kg m-3 Z3 T-2 ~> J m-2]. - real :: dPEc_dKd ! The partial derivative of PE_chg with Kddt_h(K) [J m-2 H-1 ~> J m-3 or J kg-1]. - real :: TKE_left_min, TKE_left_max ! Maximum and minimum values of TKE_left [kg m-3 Z3 T-2 ~> J m-2]. + ! recent guess at Kddt_h(K) [R Z3 T-2 ~> J m-2]. + real :: dPEc_dKd ! The partial derivative of PE_chg with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real :: TKE_left_min, TKE_left_max ! Maximum and minimum values of TKE_left [R Z3 T-2 ~> J m-2]. real :: Kddt_h_max, Kddt_h_min ! Maximum and minimum values of Kddt_h(K) [H ~> m or kg m-2]. real :: Kddt_h_guess ! A guess at the value of Kddt_h(K) [H ~> m or kg m-2]. real :: Kddt_h_next ! The next guess at the value of Kddt_h(K) [H ~> m or kg m-2]. @@ -789,7 +791,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs max_itt = 20 h_tt_min = 0.0 - I_dtrho = 0.0 ; if (dt*GV%Rho0 > 0.0) I_dtrho = (US%Z_to_m**3*US%s_to_T**3) / (dt*US%R_to_kg_m3*GV%Rho0) + I_dtrho = 0.0 ; if (dt*GV%Rho0 > 0.0) I_dtrho = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) vstar_unit_scale = US%m_to_Z * US%T_to_s MLD_guess = MLD_io @@ -805,7 +807,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs pres_Z(1) = 0.0 do k=1,nz - dMass = US%m_to_Z * GV%H_to_kg_m2 * h(k) + dMass = GV%H_to_RZ * h(k) dPres = US%L_to_Z**2 * GV%g_Earth * dMass ! Equivalent to GV%H_to_Pa * h(k) with rescaling dT_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dT(k) dS_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dS(k) @@ -863,9 +865,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !/ Apply MStar to get mech_TKE if ((CS%answers_2018) .and. (CS%mstar_scheme==Use_Fixed_MStar)) then - mech_TKE = (dt*MSTAR_total*US%R_to_kg_m3*GV%Rho0) * u_star**3 + mech_TKE = (dt*MSTAR_total*GV%Rho0) * u_star**3 else - mech_TKE = MSTAR_total * (dt*US%R_to_kg_m3*GV%Rho0* u_star**3) + mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif if (CS%TKE_diagnostics) then @@ -970,7 +972,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! on a curve fit from the data of Wang (GRL, 2003). ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*htot)**3 / conv_PErel) nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & - sqrt(0.5 * dt * US%R_to_kg_m3*GV%Rho0 * (absf*(htot*GV%H_to_Z))**3 * conv_PErel)) + sqrt(0.5 * dt * GV%Rho0 * (absf*(htot*GV%H_to_Z))**3 * conv_PErel)) endif if (debug) nstar_k(K) = nstar_FC @@ -1085,7 +1087,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if ((CS%MKE_to_TKE_effic > 0.0) .and. (htot*h(k) > 0.0)) then ! This is the energy that would be available from homogenizing the ! velocities between layer k and the layers above. - dMKE_max = (US%L_to_Z**2*US%m_to_Z*GV%H_to_kg_m2 * CS%MKE_to_TKE_effic) * 0.5 * & + dMKE_max = (US%L_to_Z**2*GV%H_to_RZ * CS%MKE_to_TKE_effic) * 0.5 * & (h(k) / ((htot + h(k))*htot)) * & ((uhtot-u(k)*htot)**2 + (vhtot-v(k)*htot)**2) ! A fraction (1-exp(Kddt_h*MKE2_Hharm)) of this energy would be @@ -1441,7 +1443,7 @@ end subroutine ePBL_column subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, ColHt_cor) + PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times !! the time step and divided by the average of the !! thicknesses around the interface [H ~> m or kg m-2]. @@ -1471,22 +1473,22 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers above [kg m-3 Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers above [R Z3 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! salinities of all the layers above [kg m-3 Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! salinities of all the layers above [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers below [kg m-3 Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers below [R Z3 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! salinities of all the layers below [kg m-3 Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! salinities of all the layers below [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. + !! as gravity waves and unavailable to drive mixing [R Z2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes @@ -1505,23 +1507,23 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [kg m-3 Z3 T-2 ~> J m-2]. + !! Kddt_h at the present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h - !! [J m-2 H-1 ~> J m-3 or J kg-1]. + !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could !! be realizedd by applying a huge value of Kddt_h at the - !! present interface [kg m-3 Z3 T-2 ~> J m-2]. + !! present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [kg m-3 Z3 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net - !! change in the column height [kg m-3 Z3 T-2 ~> J m-2]. + !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net + !! change in the column height [R Z3 T-2 ~> J m-2]. real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. real :: dT_c ! The core term in the expressions for the temperature changes [degC H2 ~> degC m2 or degC kg2 m-4]. real :: dS_c ! The core term in the expressions for the salinity changes [ppt H2 ~> ppt m2 or ppt kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes [kg m-3 Z2 T-2 ~> J m-3]. + ! for the potential energy changes [R Z2 T-2 ~> J m-3]. real :: ColHt_core ! The diffusivity-independent core term in the expressions ! for the column height changes [H Z ~> m2 or kg m-1]. real :: ColHt_chg ! The change in the column height [H ~> m or kg m-2]. @@ -1552,10 +1554,10 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & PE_chg = PEc_core * y1_3 ColHt_chg = ColHt_core * y1_3 if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - if (present(ColHt_cor)) ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) - elseif (present(ColHt_cor)) then + if (present(PE_ColHt_cor)) PE_ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) + elseif (present(PE_ColHt_cor)) then y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - ColHt_cor = -pres_Z * min(ColHt_core * y1_3, 0.0) + PE_ColHt_cor = -pres_Z * min(ColHt_core * y1_3, 0.0) endif if (present(dPEc_dKd)) then @@ -1610,23 +1612,23 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & !! salinity change in the layer above the interface [ppt]. real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. + !! as gravity waves and unavailable to drive mixing [R Z2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers below [kg m-3 Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers below [R Z3 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! in the salinities of all the layers below [kg m-3 Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! in the salinities of all the layers below [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers above [kg m-3 Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers above [R Z3 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! salinities of all the layers above [kg m-3 Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! salinities of all the layers above [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes in the @@ -1645,14 +1647,14 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [kg m-3 Z3 T-2 ~> J m-2]. + !! Kddt_h at the present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h - !! [kg m-3 Z3 T-2 H-1 ~> J m-3 or J kg-1]. + !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could !! be realizedd by applying a huge value of Kddt_h at the - !! present interface [kg m-3 Z3 T-2 ~> J m-2]. + !! present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [kg m-3 Z3 T-2 H-1 ~> J m-3 or J kg-1]. + !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. ! This subroutine determines the total potential energy change due to mixing ! at an interface, including all of the implicit effects of the prescribed @@ -1950,7 +1952,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. character(len=20) :: tmpstr real :: omega_frac_dflt - real :: Z3_T3_to_m3_s3 ! A conversion factor for work diagnostics [m3 T3 Z-3 s-3 ~> nondim] + real :: R_Z3_T3_to_kg_s3 ! A conversion factor for work diagnostics [kg T3 R-1 Z-3 s-3 ~> nondim] integer :: isd, ied, jsd, jed integer :: mstar_mode, LT_enhance, wT_mode logical :: default_2018_answers @@ -2307,25 +2309,25 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Checking output flags - Z3_T3_to_m3_s3 = US%Z_to_m**3 * US%s_to_T**3 + R_Z3_T3_to_kg_s3 = US%R_to_kg_m3 * US%Z_to_m**3 * US%s_to_T**3 CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, & Time, 'Surface boundary layer depth', 'm', conversion=US%Z_to_m, & cmor_long_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & - Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3', conversion=Z3_T3_to_m3_s3) + Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) CS%id_TKE_MKE = register_diag_field('ocean_model', 'ePBL_TKE_MKE', diag%axesT1, & - Time, 'Mean kinetic energy source of mixed layer TKE', 'm3 s-3', conversion=Z3_T3_to_m3_s3) + Time, 'Mean kinetic energy source of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) CS%id_TKE_conv = register_diag_field('ocean_model', 'ePBL_TKE_conv', diag%axesT1, & - Time, 'Convective source of mixed layer TKE', 'm3 s-3', conversion=Z3_T3_to_m3_s3) + Time, 'Convective source of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) CS%id_TKE_forcing = register_diag_field('ocean_model', 'ePBL_TKE_forcing', diag%axesT1, & Time, 'TKE consumed by mixing surface forcing or penetrative shortwave radation '//& - 'through model layers', 'm3 s-3', conversion=Z3_T3_to_m3_s3) + 'through model layers', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) CS%id_TKE_mixing = register_diag_field('ocean_model', 'ePBL_TKE_mixing', diag%axesT1, & - Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3', conversion=Z3_T3_to_m3_s3) + Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'ePBL_TKE_mech_decay', diag%axesT1, & - Time, 'Mechanical energy decay sink of mixed layer TKE', 'm3 s-3', conversion=Z3_T3_to_m3_s3) + Time, 'Mechanical energy decay sink of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'ePBL_TKE_conv_decay', diag%axesT1, & - Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3', conversion=Z3_T3_to_m3_s3) + Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) CS%id_Mixing_Length = register_diag_field('ocean_model', 'Mixing_Length', diag%axesTi, & Time, 'Mixing Length that is used', 'm', conversion=US%Z_to_m) CS%id_Velocity_Scale = register_diag_field('ocean_model', 'Velocity_Scale', diag%axesTi, & From 5122e33d2d664d9e6840f878476946925ea6cc6e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 08:15:50 -0400 Subject: [PATCH 104/259] +Rescaled density units of cTKE arguments Rescaled the density units of the cTKE or TKE_forced variables passed to energetic_PBL and applyBoundaryFluxesInOut for dimensional consistency testing. All answers are bitwise identical, but the units of an argument to two public interfaces have changed. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 8 ++++---- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 10 ++++++---- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 4 ++-- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 0158f8e274..fcc234183c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -868,7 +868,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! heat and freshwater fluxes is applied [m]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: cTKE !< Turbulent kinetic energy requirement to mix - !! forcing through each layer [kg m-3 Z3 T-2 ~> J m-2] + !! forcing through each layer [R Z3 T-2 ~> J m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: dSV_dT !< Partial derivative of specific volume with !! potential temperature [m3 kg-1 degC-1]. @@ -946,7 +946,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 ! I_G_Earth = US%Z_to_m / (US%L_T_to_m_s**2 * GV%g_Earth) - g_Hconv2 = (US%m_to_Z**3 * US%T_to_s**2) * GV%H_to_Pa * GV%H_to_kg_m2 + g_Hconv2 = (US%m_to_Z**3 * US%T_to_s**2) * GV%H_to_Pa * GV%H_to_kg_m2*US%kg_m3_to_R if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then @@ -1136,7 +1136,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z**3 * US%T_to_s**2) * GV%Z_to_H*GV%H_to_Pa - cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & + cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*US%kg_m3_to_R*dSV_dS(i,j,1) * & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) endif @@ -1283,7 +1283,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t .false., .true., T2d, Pen_SW_bnd, TKE=pen_TKE_2d, dSV_dT=dSV_dT_2d) k = 1 ! For setting break-points. do k=1,nz ; do i=is,ie - cTKE(i,j,k) = cTKE(i,j,k) + pen_TKE_2d(i,k) + cTKE(i,j,k) = cTKE(i,j,k) + US%kg_m3_to_R*pen_TKE_2d(i,k) enddo ; enddo else call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt_in_T, H_limit_fluxes, & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index a9505c6a91..cc8b27620e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -485,7 +485,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! [H ~> m or kg m-2] dSV_dT, & ! The partial derivative of specific volume with temperature [m3 kg-1 degC-1] dSV_dS, & ! The partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. - cTKE, & ! convective TKE requirements for each layer [kg m-3 Z3 T-2 ~> J m-2]. + cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. u_h, & ! zonal and meridional velocities at thickness points after v_h ! entrainment [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & @@ -835,7 +835,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call hchksum(eb_t, "after applyBoundaryFluxes eb_t",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(ea_s, "after applyBoundaryFluxes ea_s",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(eb_s, "after applyBoundaryFluxes eb_s",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0) + call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0, & + scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) endif @@ -1268,7 +1269,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! [H ~> m or kg m-2] dSV_dT, & ! The partial derivative of specific volume with temperature [m3 kg-1 degC-1] dSV_dS, & ! The partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. - cTKE, & ! convective TKE requirements for each layer [kg m-3 Z3 T-2 ~> J m-2]. + cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. u_h, & ! zonal and meridional velocities at thickness points after v_h ! entrainment [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & @@ -1565,7 +1566,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call hchksum(eb_t, "after applyBoundaryFluxes eb_t",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(ea_s, "after applyBoundaryFluxes ea_s",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(eb_s, "after applyBoundaryFluxes eb_s",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0) + call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0, & + scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 5cdc151182..e276c82517 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -261,7 +261,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: TKE_forced !< The forcing requirements to homogenize the !! forcing that has been applied to each layer - !! [kg m-3 Z3 T-2 ~> J m-2]. + !! [R Z3 T-2 ~> J m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. @@ -406,7 +406,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do k=1,nz ; do i=is,ie h_2d(i,k) = h_3d(i,j,k) ; u_2d(i,k) = u_3d(i,j,k) ; v_2d(i,k) = v_3d(i,j,k) T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) - TKE_forced_2d(i,k) = US%kg_m3_to_R*TKE_forced(i,j,k) + TKE_forced_2d(i,k) = TKE_forced(i,j,k) dSV_dT_2d(i,k) = US%R_to_kg_m3*dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = US%R_to_kg_m3*dSV_dS(i,j,k) enddo ; enddo From 2d1f6478654fd422efa2584835c70c265674fe97 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 10:17:08 -0400 Subject: [PATCH 105/259] +Rescaled specific volume units of dSV_dT args Rescaled the specific volume (density) units of the dSV_dT and dSV_dS variables passed to energetic_PBL, applyBoundaryFluxesInOut, and absorbRemainingSW for dimensional consistency testing. Also rescaled the dimensions of TKE returned from absorbRemainingSW. All answers are bitwise identical, but the units of a arguments to 3 public interfaces have changed. --- .../vertical/MOM_diabatic_aux.F90 | 28 ++++++++++--------- .../vertical/MOM_diabatic_driver.F90 | 22 +++++++-------- .../vertical/MOM_energetic_PBL.F90 | 6 ++-- .../vertical/MOM_opacity.F90 | 10 +++---- 4 files changed, 34 insertions(+), 32 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index fcc234183c..0b71ca21d1 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -871,10 +871,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! forcing through each layer [R Z3 T-2 ~> J m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: dSV_dT !< Partial derivative of specific volume with - !! potential temperature [m3 kg-1 degC-1]. + !! potential temperature [R-1 degC-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: dSV_dS !< Partial derivative of specific volume with - !! salinity [m3 kg-1 ppt-1]. + !! salinity [R-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. @@ -909,8 +909,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] T2d, & ! A 2-d copy of the layer temperatures [degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within - ! a layer [kg m-3 Z3 T-2 ~> J m-2] - dSV_dT_2d ! The partial derivative of specific volume with temperature [m3 kg-1 degC-1] + ! a layer [R Z3 T-2 ~> J m-2] + dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 degC-1] real, dimension(SZI_(G),SZK_(G)+1) :: netPen real, dimension(max(nsw,1),SZI_(G)) :: & Pen_SW_bnd, & ! The penetrative shortwave heating integrated over a timestep by band @@ -922,9 +922,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] real, dimension(maxGroundings) :: hGrounding real :: Temp_in, Salin_in -! real :: I_G_Earth ! The inverse of the gravitational acceleration with conversion factors [s2 m-1]. +! real :: I_G_Earth ! The inverse of the gravitational acceleration with conversion factors [R m2 kg-1 s2 ~> s2 m-1] real :: dt_in_T ! The time step converted to T units [T ~> s] - real :: g_Hconv2 + real :: g_Hconv2 ! A conversion factor for use in the TKE calculation + ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. real :: GoRho ! g_Earth times a unit conversion factor divided by density ! [Z3 m T-2 kg-1 ~> m4 s-2 kg-1] logical :: calculate_energetics @@ -945,8 +946,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 -! I_G_Earth = US%Z_to_m / (US%L_T_to_m_s**2 * GV%g_Earth) - g_Hconv2 = (US%m_to_Z**3 * US%T_to_s**2) * GV%H_to_Pa * GV%H_to_kg_m2*US%kg_m3_to_R +! I_G_Earth = US%kg_m3_to_R*US%Z_to_m / (US%L_T_to_m_s**2 * GV%g_Earth) + g_Hconv2 = (US%m_to_Z**3 * US%T_to_s**2) * GV%H_to_Pa * GV%H_to_kg_m2*US%kg_m3_to_R**2 if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then @@ -1004,7 +1005,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pres(i) = pres(i) + d_pres(i) enddo call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:),& - dSV_dT(:,j,k), dSV_dS(:,j,k), is, ie-is+1, tv%eqn_of_state) + dSV_dT(:,j,k), dSV_dS(:,j,k), is, ie-is+1, tv%eqn_of_state, scale=US%R_to_kg_m3) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo ! do i=is,ie ! dT_to_dPE(i,k) = I_G_Earth * d_pres(i) * p_lay(i) * dSV_dT(i,j,k) @@ -1134,10 +1135,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z**3 * US%T_to_s**2) * GV%Z_to_H*GV%H_to_Pa + RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z**3 * US%T_to_s**2) * & + GV%Z_to_H*GV%H_to_Pa*US%kg_m3_to_R - cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*US%kg_m3_to_R*dSV_dS(i,j,1) * & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) + cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & + US%kg_m3_to_R*(fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) endif ! Update state @@ -1283,7 +1285,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t .false., .true., T2d, Pen_SW_bnd, TKE=pen_TKE_2d, dSV_dT=dSV_dT_2d) k = 1 ! For setting break-points. do k=1,nz ; do i=is,ie - cTKE(i,j,k) = cTKE(i,j,k) + US%kg_m3_to_R*pen_TKE_2d(i,k) + cTKE(i,j,k) = cTKE(i,j,k) + pen_TKE_2d(i,k) enddo ; enddo else call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt_in_T, H_limit_fluxes, & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index cc8b27620e..631062c22c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -483,8 +483,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim hold, & ! layer thickness before diapycnal entrainment, and later ! the initial layer thicknesses (if a mixed layer is used), ! [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. + dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. u_h, & ! zonal and meridional velocities at thickness points after v_h ! entrainment [L T-1 ~> m s-1] @@ -835,10 +835,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call hchksum(eb_t, "after applyBoundaryFluxes eb_t",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(ea_s, "after applyBoundaryFluxes ea_s",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(eb_s, "after applyBoundaryFluxes eb_s",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0, & + call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) - call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) - call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, scale=US%kg_m3_to_R) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, scale=US%kg_m3_to_R) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1267,8 +1267,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! hold, & ! layer thickness before diapycnal entrainment, and later ! the initial layer thicknesses (if a mixed layer is used), ! [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. + dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. u_h, & ! zonal and meridional velocities at thickness points after v_h ! entrainment [L T-1 ~> m s-1] @@ -1568,8 +1568,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call hchksum(eb_s, "after applyBoundaryFluxes eb_s",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0, & scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) - call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) - call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0, scale=US%kg_m3_to_R) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0, scale=US%kg_m3_to_R) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1942,8 +1942,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e hold, & ! layer thickness before diapycnal entrainment, and later ! the initial layer thicknesses (if a mixed layer is used), ! [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. + dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [kg m-3 Z3 T-2 ~> J m-2]. u_h, & ! zonal and meridional velocities at thickness points after v_h ! entrainment [L T-1 ~> m s-1] diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index e276c82517..0174bfaa58 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -254,10 +254,10 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dSV_dT !< The partial derivative of in-situ specific !! volume with potential temperature - !! [m3 kg-1 degC-1]. + !! [R-1 degC-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dSV_dS !< The partial derivative of in-situ specific - !! volume with salinity [m3 kg-1 ppt-1]. + !! volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: TKE_forced !< The forcing requirements to homogenize the !! forcing that has been applied to each layer @@ -407,7 +407,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS h_2d(i,k) = h_3d(i,j,k) ; u_2d(i,k) = u_3d(i,j,k) ; v_2d(i,k) = v_3d(i,j,k) T_2d(i,k) = tv%T(i,j,k) ; S_2d(i,k) = tv%S(i,j,k) TKE_forced_2d(i,k) = TKE_forced(i,j,k) - dSV_dT_2d(i,k) = US%R_to_kg_m3*dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = US%R_to_kg_m3*dSV_dS(i,j,k) + dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = dSV_dS(i,j,k) enddo ; enddo ! Determine the initial mech_TKE and conv_PErel, including the energy required diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 5e42de0fea..d7905f1dc9 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -556,9 +556,9 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l real, dimension(SZI_(G)), optional, intent(inout) :: Ttot !< Depth integrated mixed layer !! temperature [degC H ~> degC m or degC kg m-2] real, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: dSV_dT !< The partial derivative of specific - !! volume with temperature [m3 kg-1 degC-1]. + !! volume with temperature [R-1 degC-1]. real, dimension(SZI_(G),SZK_(GV)), optional, intent(inout) :: TKE !< The TKE sink from mixing the heating - !! throughout a layer [kg m-3 Z3 T-2 ~> J m-2]. + !! throughout a layer [R Z3 T-2 ~> J m-2]. ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & @@ -599,7 +599,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l real :: epsilon ! A small thickness that must remain in each ! layer, and which will not be subject to heating [H ~> m or kg m-2] real :: g_Hconv2 ! A conversion factor for use in the TKE calculation - ! in units of [Z3 kg2 m-6 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. + ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. logical :: SW_Remains ! If true, some column has shortwave radiation that ! was not entirely absorbed. logical :: TKE_calc ! If true, calculate the implications to the @@ -618,9 +618,9 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l TKE_calc = (present(TKE) .and. present(dSV_dT)) if (optics%answers_2018) then - g_Hconv2 = (US%m_to_Z**2 * US%L_to_Z**2*GV%g_Earth * GV%H_to_kg_m2) * GV%H_to_kg_m2 + g_Hconv2 = (US%m_to_Z**2 * US%L_to_Z**2*GV%g_Earth * GV%H_to_kg_m2) * GV%H_to_kg_m2 * US%kg_m3_to_R**2 else - g_Hconv2 = US%m_to_Z**2 * US%L_to_Z**2*GV%g_Earth * GV%H_to_kg_m2**2 + g_Hconv2 = US%m_to_Z**2 * US%L_to_Z**2*GV%g_Earth * GV%H_to_kg_m2**2 * US%kg_m3_to_R**2 endif h_heat(:) = 0.0 From 08231ca22ccf5ac11ec5c5417b49ca3ba7af82a5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 13:47:58 -0400 Subject: [PATCH 106/259] Used GV%H_to_RZ to simplify rescalings Used GV%H_to_RZ to simplify rescalings in applyBoundaryFluxesInOut and absorbRemainingSW. All answer are bitwise identical. --- .../vertical/MOM_diabatic_aux.F90 | 16 ++++++---------- src/parameterizations/vertical/MOM_opacity.F90 | 4 ++-- 2 files changed, 8 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 0b71ca21d1..1884aa9da7 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -922,7 +922,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] real, dimension(maxGroundings) :: hGrounding real :: Temp_in, Salin_in -! real :: I_G_Earth ! The inverse of the gravitational acceleration with conversion factors [R m2 kg-1 s2 ~> s2 m-1] real :: dt_in_T ! The time step converted to T units [T ~> s] real :: g_Hconv2 ! A conversion factor for use in the TKE calculation ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. @@ -946,8 +945,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 -! I_G_Earth = US%kg_m3_to_R*US%Z_to_m / (US%L_T_to_m_s**2 * GV%g_Earth) - g_Hconv2 = (US%m_to_Z**3 * US%T_to_s**2) * GV%H_to_Pa * GV%H_to_kg_m2*US%kg_m3_to_R**2 + g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then @@ -1007,10 +1005,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:),& dSV_dT(:,j,k), dSV_dS(:,j,k), is, ie-is+1, tv%eqn_of_state, scale=US%R_to_kg_m3) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo -! do i=is,ie -! dT_to_dPE(i,k) = I_G_Earth * d_pres(i) * p_lay(i) * dSV_dT(i,j,k) -! dS_to_dPE(i,k) = I_G_Earth * d_pres(i) * p_lay(i) * dSV_dS(i,j,k) -! enddo enddo pen_TKE_2d(:,:) = 0.0 endif @@ -1135,9 +1129,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z**3 * US%T_to_s**2) * & - GV%Z_to_H*GV%H_to_Pa*US%kg_m3_to_R - + if (GV%Boussinesq) then + RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + else + RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) + endif cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & US%kg_m3_to_R*(fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) endif diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index d7905f1dc9..9a0eef8dc3 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -618,9 +618,9 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l TKE_calc = (present(TKE) .and. present(dSV_dT)) if (optics%answers_2018) then - g_Hconv2 = (US%m_to_Z**2 * US%L_to_Z**2*GV%g_Earth * GV%H_to_kg_m2) * GV%H_to_kg_m2 * US%kg_m3_to_R**2 + g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ else - g_Hconv2 = US%m_to_Z**2 * US%L_to_Z**2*GV%g_Earth * GV%H_to_kg_m2**2 * US%kg_m3_to_R**2 + g_Hconv2 = US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ**2 endif h_heat(:) = 0.0 From 8e231df070e3a54e7a1c453674d43c85f83317bd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 15:36:54 -0400 Subject: [PATCH 107/259] +Pass mixed layer densities to sponges in [R] Rescaled the units of the mixed layer densities passed to apply_sponge and set_up_sponge_ML_density to [R] for dimensional consistency testing. This required adding a unit_scale_type argument to RGC_initalize_sponges. All answers are bitwise identical, but the units of two arguments to public interfaces have changed. --- src/initialization/MOM_state_initialization.F90 | 4 ++-- .../vertical/MOM_diabatic_driver.F90 | 2 +- src/parameterizations/vertical/MOM_sponge.F90 | 12 ++++++------ src/user/RGC_initialization.F90 | 12 +++++++----- 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index c061169854..b0a81a53e8 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -544,7 +544,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & sponge_CSp, ALE_sponge_CSp) case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, US, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) - case("RGC"); call RGC_initialize_sponges(G, GV, tv, u, v, PF, useALE, & + case("RGC"); call RGC_initialize_sponges(G, GV, US, tv, u, v, PF, useALE, & sponge_CSp, ALE_sponge_CSp) case ("USER"); call user_initialize_sponges(G, GV, use_temperature, tv, PF, sponge_CSp, h) case ("BFB"); call BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, PF, & @@ -1853,7 +1853,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C do j=js,je call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), & - is, ie-is+1, tv%eqn_of_state) + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo call set_up_sponge_ML_density(tmp_2d, G, CSp) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 631062c22c..7da5fa7bed 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2689,7 +2689,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) do j=js,je call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & - is, ie-is+1, tv%eqn_of_state) + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 744f1fbaf7..2bc42e29ff 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -57,7 +57,7 @@ module MOM_sponge integer, pointer :: col_j(:) => NULL() !< Array of the j-indicies of each of the columns being damped. real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each column. real, pointer :: Rcv_ml_ref(:) => NULL() !< The value toward which the mixed layer - !! coordinate-density is being damped [kg m-3]. + !! coordinate-density is being damped [R ~> kg m-3]. real, pointer :: Ref_eta(:,:) => NULL() !< The value toward which the interface !! heights are being damped [Z ~> m]. type(p3d) :: var(MAX_FIELDS_) !< Pointers to the fields that are being damped. @@ -67,7 +67,7 @@ module MOM_sponge real, pointer :: Iresttime_im(:) => NULL() !< The inverse restoring time of !! each row for i-mean sponges. real, pointer :: Rcv_ml_ref_im(:) => NULL() !! The value toward which the i-mean - !< mixed layer coordinate-density is being damped [kg m-3]. + !< mixed layer coordinate-density is being damped [R ~> kg m-3]. real, pointer :: Ref_eta_im(:,:) => NULL() !< The value toward which the i-mean !! interface heights are being damped [Z ~> m]. type(p2d) :: Ref_val_im(MAX_FIELDS_) !< The values toward which the i-means of @@ -274,12 +274,12 @@ end subroutine set_up_sponge_field subroutine set_up_sponge_ML_density(sp_val, G, CS, sp_val_i_mean) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: sp_val !< The reference values of the mixed layer density [kg m-3] + intent(in) :: sp_val !< The reference values of the mixed layer density [R ~> kg m-3] type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that is !! set by a previous call to initialize_sponge. real, dimension(SZJ_(G)), & optional, intent(in) :: sp_val_i_mean !< the reference values of the zonal mean mixed - !! layer density [kg m-3], for use if Iresttime_i_mean > 0. + !! layer density [R ~> kg m-3], for use if Iresttime_i_mean > 0. ! This subroutine stores the reference value for mixed layer density. It is ! handled differently from other values because it is only used in determining ! which layers can be inflated. @@ -336,7 +336,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_sponge. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: Rcv_ml !< The coordinate density of the mixed layer [kg m-3]. + optional, intent(inout) :: Rcv_ml !< The coordinate density of the mixed layer [R ~> kg m-3]. ! This subroutine applies damping to the layers thicknesses, mixed ! layer buoyancy, and a variety of tracers for every column where @@ -499,7 +499,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) wpb = 0.0; wb = 0.0 do k=nz,nkmb+1,-1 - if (US%R_to_kg_m3*GV%Rlay(k) > Rcv_ml(i,j)) then + if (GV%Rlay(k) > Rcv_ml(i,j)) then w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w-ABS(w)) diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index d5f2bb608b..f84a634976 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -22,8 +22,7 @@ module RGC_initialization use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge use MOM_ALE_sponge, only : set_up_ALE_sponge_vel_field -use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge -use MOM_sponge, only : set_up_sponge_ML_density +use MOM_domains, only : pass_var use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type @@ -31,10 +30,12 @@ module RGC_initialization use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data use MOM_io, only : slasher +use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_sponge, only : set_up_sponge_ML_density +use MOM_unit_scaling, only : unit_scale_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 MOM_domains, only: pass_var implicit none ; private #include @@ -46,9 +47,10 @@ module RGC_initialization !> Sets up the the inverse restoration time, and the values towards which the interface heights, !! velocities and tracers should be restored within the sponges for the RGC test case. -subroutine RGC_initialize_sponges(G, GV, tv, u, v, PF, use_ALE, CSp, ACSp) +subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers !! to any available thermodynamic !! fields, potential temperature and @@ -222,7 +224,7 @@ subroutine RGC_initialize_sponges(G, GV, tv, u, v, PF, use_ALE, CSp, ACSp) do j=js,je call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), & - is, ie-is+1, tv%eqn_of_state) + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo call set_up_sponge_ML_density(tmp, G, CSp) From e5ca06e972318798976d226281dc2cc84ce3e0e8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 18:13:41 -0400 Subject: [PATCH 108/259] Rescaled units of dRhodT in applyBoundaryFluxesInOut Rescaled units of dRhodT in applyBoundaryFluxesInOut for dimensional consistency testing. All answers are bitwise identical. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 1884aa9da7..97cb92a756 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -899,8 +899,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t nonpenSW, & ! non-downwelling SW, which is absorbed at ocean surface ! [degC H ~> degC m or degC kg m-2] SurfPressure, & ! Surface pressure (approximated as 0.0) [Pa] - dRhodT, & ! change in density per change in temperature [kg m-3 degC-1] - dRhodS, & ! change in density per change in salinity [kg m-3 ppt-1] + dRhodT, & ! change in density per change in temperature [R degC-1 ~> kg m-3 degC-1] + dRhodS, & ! change in density per change in salinity [R ppt-1 ~> kg m-3 ppt-1] netheat_rate, & ! netheat but for dt=1 [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -926,7 +926,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t real :: g_Hconv2 ! A conversion factor for use in the TKE calculation ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. real :: GoRho ! g_Earth times a unit conversion factor divided by density - ! [Z3 m T-2 kg-1 ~> m4 s-2 kg-1] + ! [Z T-2 R-1 ~> m4 s-2 kg-1] logical :: calculate_energetics logical :: calculate_buoyancy integer :: i, j, is, ie, js, je, k, nz, n @@ -950,7 +950,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then SurfPressure(:) = 0.0 - GoRho = US%L_to_Z**2*GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 start = 1 + G%isc - G%isd npts = 1 + G%iec - G%isc endif @@ -1341,7 +1341,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t 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) + dRhodT, dRhodS, start, npts, tv%eqn_of_state, scale=US%kg_m3_to_R) ! 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. @@ -1350,7 +1350,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t do i=is,ie SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * US%T_to_s * & (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 + dRhodT(i) * ( netHeat_rate(i) + netPen(i,1)) ) ! [Z2 T-3 ~> m2 s-3] enddo endif From 2e3f9c4ae0d0e691b4f12232376b20019e6613b7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 21:45:28 -0400 Subject: [PATCH 109/259] Rescaled density units in MOM_thickness_diffuse Rescaled density units in MOM_thickness_diffuse for dimensional consistency testing. All answers are bitwise identical. --- .../lateral/MOM_thickness_diffuse.F90 | 66 +++++++++---------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 63385733ec..d30c2baa5a 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -36,7 +36,7 @@ module MOM_thickness_diffuse !> Control structure for thickness diffusion type, public :: thickness_diffuse_CS ; private real :: Khth !< Background interface depth diffusivity [L2 T-1 ~> m2 s-1] - real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [m2 s-1] + real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [nondim] real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max @@ -122,13 +122,13 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp int_slope_u ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at u points. The physically correct - ! slopes occur at 0, while 1 is used for numerical closures. + ! slopes occur at 0, while 1 is used for numerical closures [nondim]. real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: & KH_v, & ! interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] int_slope_v ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at v points. The physically correct - ! slopes occur at 0, while 1 is used for numerical closures. + ! slopes occur at 0, while 1 is used for numerical closures [nondim]. real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & KH_t ! diagnosed diffusivity at tracer points [L2 T-1 ~> m2 s-1] @@ -522,7 +522,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces !! at u points [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces - !! at v points [m2 s-1] + !! at v points [L2 T-1 ~> m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uhD !< Zonal mass fluxes !! [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -535,11 +535,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration of - !! density gradients. + !! density gradients [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration of - !! density gradients. + !! density gradients [nondim]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: slope_x !< Isopycnal slope at u-points real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: slope_y !< Isopycnal slope at v-points ! Local variables @@ -548,8 +548,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, ! in massless layers filled vertically by diffusion. S, & ! The filled salinity [ppt], with the values in ! in massless layers filled vertically by diffusion. - Rho, & ! Density itself [kg m-3], when a nonlinear equation of state is - ! not in use. h_avail, & ! The mass available for diffusion out of each face, divided ! by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. h_frac ! The fraction of the mass in the column above the bottom @@ -566,11 +564,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, pres, & ! The pressure at an interface [Pa]. h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & - drho_dT_u, & ! The derivative of density with temperature at u points [kg m-3 degC-1] - drho_dS_u ! The derivative of density with salinity at u points [kg m-3 ppt-1]. + drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] + drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)) :: & - drho_dT_v, & ! The derivative of density with temperature at v points [kg m-3 degC-1] - drho_dS_v ! The derivative of density with salinity at v points [kg m-3 ppt-1]. + drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] + drho_dS_v ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & @@ -582,27 +580,27 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, S_v, & ! Salinity on the interface at the v-point [ppt]. pres_v ! Pressure on the interface at the v-point [Pa]. real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness - real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [W]. + real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [ kg L2 s-3 ~> W ] real :: Work_h ! The work averaged over an h-cell [W m-2]. real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] ! The calculation is equal to h * S^2 * N^2 * kappa_GM. real :: I4dt ! 1 / 4 dt [T-1 ~> s-1]. real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the - ! interface times the grid spacing [kg m-3]. - real :: drdkL, drdkR ! Vertical density differences across an interface [kg m-3]. - real :: drdi_u(SZIB_(G), SZK_(G)+1) ! Copy of drdi at u-points [kg m-3]. - real :: drdj_v(SZI_(G), SZK_(G)+1) ! Copy of drdj at v-points [kg m-3]. + ! interface times the grid spacing [R ~> kg m-3]. + real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. + real :: drdi_u(SZIB_(G), SZK_(G)+1) ! Copy of drdi at u-points [R ~> kg m-3]. + real :: drdj_v(SZI_(G), SZK_(G)+1) ! Copy of drdj at v-points [R ~> kg m-3]. real :: drdkDe_u(SZIB_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at u-points - ! [Z kg m-3 ~> kg m-2]. + ! [Z R ~> kg m-2]. real :: drdkDe_v(SZI_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at v-points - ! [Z kg m-3 ~> kg m-2]. + ! [Z R ~> kg m-2]. real :: hg2A, hg2B, hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m]. real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. - real :: drdx, drdy ! Zonal and meridional density gradients [kg m-3 L-1 ~> kg m-4]. - real :: drdz ! Vertical density gradient [kg m-3 Z-1 ~> kg m-4]. + real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. + real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. real :: c2_h_u(SZIB_(G), SZK_(G)+1) ! Wave speed squared divided by h at u-points [L2 Z-1 T-2 ~> m s-2]. real :: c2_h_v(SZI_(G), SZK_(G)+1) ! Wave speed squared divided by h at v-points [L2 Z-1 T-2 ~> m s-2]. @@ -620,7 +618,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, ! good thing to use when the slope is so large as to be meaningless [Z L2 T-1 ~> m3 s-1]. real :: Slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1, nondimensional. - real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [kg2 m-6 L-2 ~> kg2 m-8]. + real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. real :: I_slope_max2 ! The inverse of slope_max squared, nondimensional. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -628,12 +626,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, real :: dz_neglect ! A thickness [Z ~> m], that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. real :: G_scale ! The gravitational acceleration times some unit conversion - ! factors [m3 T Z-1 H-1 s-3 ~> m s-2 or m4 kg-1 s-2]. + ! factors [kg T R-1 Z-1 H-1 s-3 ~> m s-2 or m4 kg-1 s-2]. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. - real :: G_rho0 ! g/Rho0 [L2 m3 Z-1 T-2 ~> m4 s-2]. + real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics @@ -646,10 +644,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, I4dt = 0.25 / (dt_in_T) I_slope_max2 = 1.0 / (CS%slope_max**2) - G_scale = GV%g_Earth*US%L_to_m**2*US%s_to_T**3 * GV%H_to_m + G_scale = GV%g_Earth*US%L_to_m**2*US%s_to_T**3 * GV%H_to_m * US%R_to_kg_m3 h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 dz_neglect = GV%H_subroundoff*GV%H_to_Z - G_rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + G_rho0 = GV%g_Earth / GV%Rho0 N2_floor = CS%N2_floor*US%Z_to_L**2 use_EOS = associated(tv%eqn_of_state) @@ -718,7 +716,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect, & !$OMP I_slope_max2,h_neglect2,present_int_slope_u, & !$OMP int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & -!$OMP uhD,h_avail,G_scale,work_u,CS,slope_x,cg1, & +!$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1, & !$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor, & !$OMP present_slope_x,G_rho0) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & @@ -732,7 +730,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 - drdkL = US%R_to_kg_m3*(GV%Rlay(k) - GV%Rlay(k-1)) ; drdkR = drdkL + drdkL = GV%Rlay(k) - GV%Rlay(k-1) ; drdkR = drdkL endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & @@ -746,7 +744,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) + drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do I=is-1,ie @@ -984,7 +982,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 - drdkL = US%R_to_kg_m3*(GV%Rlay(k) - GV%Rlay(k-1)) ; drdkR = drdkL + drdkL = GV%Rlay(k) - GV%Rlay(k-1) ; drdkR = drdkL endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & @@ -997,7 +995,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & - drho_dS_v, is, ie-is+1, tv%eqn_of_state) + drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=is,ie if (calc_derivatives) then @@ -1229,7 +1227,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, S_u(I) = 0.5*(S(i,j,1) + S(i+1,j,1)) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) + drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) @@ -1254,7 +1252,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, S_v(i) = 0.5*(S(i,j,1) + S(i,j+1,1)) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & - drho_dS_v, is, ie-is+1, tv%eqn_of_state) + drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=is,ie vhD(i,J,1) = -vhtot(i,J) @@ -1283,8 +1281,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, if (associated(CS%GMwork)) CS%GMwork(i,j) = Work_h if (associated(MEKE)) then ; if (associated(MEKE%GM_src)) then if (CS%GM_src_alt) then + !### This expression is in [L2 T-3 m ~> m3 s-3] MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%L_to_m**2*US%m_to_Z*PE_release_h else + !### This expression is in [L2 T-3 kg m-2 ~> kg s-3] MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%m_to_L**2*US%T_to_s**3*Work_h endif endif ; endif From 3fb51fd02f952c12b51e956bf723d9919b45a5af Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Sep 2019 21:45:54 -0400 Subject: [PATCH 110/259] Rescaled units of FrictWork in MOM_hor_visc.F90 Rescaled units of diagnostic FrictWork variables in MOM_hor_visc.F90 for dimensional consistency testing. All answers are bitwise identical. --- .../lateral/MOM_hor_visc.F90 | 44 ++++++++++--------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 82d20c239b..7384c30a35 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -246,7 +246,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [H L2 T-2 ~> m3 s-2 or kg s-2] bhstr_xx,& ! A copy of str_xx that only contains the biharmonic contribution ! [H L2 T-2 ~> m3 s-2 or kg s-2] - FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [kg m-2 L2 T-3 ~> W m-2] + FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] ! Leith_Kh_h, & ! Leith Laplacian viscosity at h-points [m2 s-1] ! Leith_Ah_h, & ! Leith bi-harmonic viscosity at h-points [m4 s-1] ! beta_h, & ! Gradient of planetary vorticity at h-points [L-1 T-1 ~> m-1 s-1] @@ -302,10 +302,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, max_diss_rate, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] target_diss_rate_GME, & ! the maximum theoretical dissipation plus the amount spuriously dissipated ! by friction [L2 T-3 ~> m2 s-3] - FrictWork, & ! work done by MKE dissipation mechanisms [kg m-2 L2 T-3 ~> W m-2] - FrictWork_diss, & ! negative definite work done by MKE dissipation mechanisms [kg m-2 L2 T-3 ~> W m-2] - FrictWorkMax, & ! maximum possible work done by MKE dissipation mechanisms [kg m-2 L2 T-3 ~> W m-2] - FrictWork_GME, & ! work done by GME [kg m-2 L2 T-3 ~> W m-2] + FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] + FrictWork_diss, & ! negative definite work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] + FrictWorkMax, & ! maximum possible work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] + FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h ! horizontal divergence [T-1 ~> s-1] ! real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & @@ -1191,8 +1191,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! This is the maximum possible amount of energy that can be converted ! per unit time, according to theory (multiplied by h) max_diss_rate(i,j,k) = 2.0*MEKE%MEKE(i,j) * sqrt(grad_vel_mag_h(i,j)) - FrictWork_diss(i,j,k) = diss_rate(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 - FrictWorkMax(i,j,k) = -max_diss_rate(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 + FrictWork_diss(i,j,k) = diss_rate(i,j,k) * h(i,j,k) * GV%H_to_RZ + FrictWorkMax(i,j,k) = -max_diss_rate(i,j,k) * h(i,j,k) * GV%H_to_RZ ! Determine how much work GME needs to do to reach the "target" ratio between ! the amount of work actually done and the maximum allowed by theory. Note that @@ -1203,7 +1203,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif else - FrictWork_diss(i,j,k) = diss_rate(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 + + FrictWork_diss(i,j,k) = diss_rate(i,j,k) * h(i,j,k) * GV%H_to_RZ endif ; endif enddo ; enddo @@ -1269,7 +1270,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (associated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie - FrictWork_GME(i,j,k) = GME_coeff_h(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 * grad_vel_mag_bt_h(i,j) + FrictWork_GME(i,j,k) = GME_coeff_h(i,j,k) * h(i,j,k) * GV%H_to_RZ * grad_vel_mag_bt_h(i,j) enddo ; enddo endif @@ -1334,7 +1335,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (find_FrictWork) then ; do j=js,je ; do i=is,ie ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion - FrictWork(i,j,k) = GV%H_to_kg_m2 * ( & + FrictWork(i,j,k) = GV%H_to_RZ * ( & (str_xx(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & -str_xx(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & +0.25*((str_xy(I,J)*( & @@ -1368,7 +1369,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_GME) then do j=js,je ; do i=is,ie ! MEKE%mom_src now is sign definite because it only uses the dissipation - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + MAX(FrictWork_diss(i,j,k), FrictWorkMax(i,j,k)) + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (US%R_to_kg_m3*US%Z_to_m) * & + MAX(FrictWork_diss(i,j,k), FrictWorkMax(i,j,k)) enddo ; enddo else ! use_GME if (MEKE%backscatter_Ro_c /= 0.) then @@ -1395,7 +1397,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, RoScl = Sh_F_pow / (1.0 + Sh_F_pow) ! = 1 - f^n/(f^n+c*D^n) endif endif - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_kg_m2 * ( & + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * (US%R_to_kg_m3*US%Z_to_m) * ( & ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & +0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J))*( & @@ -1404,7 +1406,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, +(str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1))*( & (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J))*( & + +((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J))*( & (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & +(str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1))*( & @@ -1413,7 +1415,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo else ! MEKE%backscatter_Ro_c do j=js,je ; do i=is,ie - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (US%R_to_kg_m3*US%Z_to_m) * FrictWork(i,j,k) enddo ; enddo endif ! MEKE%backscatter_Ro_c endif !use GME @@ -1421,7 +1423,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_GME .and. associated(MEKE)) then if (associated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie - MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + FrictWork_GME(i,j,k) + MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + (US%R_to_kg_m3*US%Z_to_m) * FrictWork_GME(i,j,k) enddo ; enddo endif endif @@ -2196,26 +2198,28 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & - 'W m-2', conversion=US%s_to_T**3*US%L_to_m**2) + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) endif CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& - 'Integral work done by lateral friction terms', 'W m-2', conversion=US%s_to_T**3*US%L_to_m**2) + 'Integral work done by lateral friction terms', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) CS%id_FrictWork_diss = register_diag_field('ocean_model','FrictWork_diss',diag%axesTL,Time,& 'Integral work done by lateral friction terms (excluding diffusion of energy)', & - 'W m-2', conversion=US%s_to_T**3*US%L_to_m**2) + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) if (associated(MEKE)) then if (associated(MEKE%mom_src)) then CS%id_FrictWorkMax = register_diag_field('ocean_model', 'FrictWorkMax', diag%axesTL, Time,& 'Maximum possible integral work done by lateral friction terms', & - 'W m-2', conversion=US%s_to_T**3*US%L_to_m**2) + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) endif endif CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & - 'Depth integrated work done by lateral friction', 'W m-2', conversion=US%s_to_T**3*US%L_to_m**2, & + 'Depth integrated work done by lateral friction', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2, & cmor_field_name='dispkexyfo', & cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') From 04901cd0ae3a14c5d1e8397b5be507d8d2413dd8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Sep 2019 07:25:36 -0400 Subject: [PATCH 111/259] Rescaled density units in MOM_mixed_layer_restrat Rescaled density units in MOM_mixed_layer_restrat for dimensional consistency testing. All answers are bitwise identical. --- .../lateral/MOM_mixed_layer_restrat.F90 | 33 ++++++++++--------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index ca62160bc1..182ec2dc0c 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -50,7 +50,7 @@ module MOM_mixed_layer_restrat !! based on the parameter MLE_DENSITY_DIFF. real :: MLE_MLD_decay_time !< Time-scale to use in a running-mean when MLD is retreating [T ~> s]. real :: MLE_MLD_decay_time2 !< Time-scale to use in a running-mean when filtered MLD is retreating [T ~> s]. - real :: MLE_density_diff !< Density difference used in detecting mixed-layer depth [kg m-3]. + real :: MLE_density_diff !< Density difference used in detecting mixed-layer depth [R ~> kg m-3]. real :: MLE_tail_dh !< Fraction by which to extend the mixed-layer restratification !! depth used for a smoother stream function at the base of !! the mixed-layer [nondim]. @@ -147,8 +147,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_slow, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] Rml_av_slow ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [m3 L2 Z-1 T-2 kg-1 ~> m4 s-2 kg-1] - real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [kg m-3] + real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] real :: p0(SZI_(G)) ! A pressure of 0 [Pa] real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). @@ -174,11 +174,12 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in ! 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 + real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [R ~> kg m-3] real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer densities [Pa]. real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 - real :: aFac, bFac, ddRho + real :: aFac, bFac ! Nondimensional ratios [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] real :: hAtVel, zpa, zpb, dh, res_scaling_fac real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] logical :: proper_averaging, line_is_empty, keep_going, res_upscale @@ -205,7 +206,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in pRef_MLD(:) = 0. do j = js-1, je+1 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) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is-1, ie-is+3, & + tv%eqn_of_state, scale=US%kg_m3_to_R) deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. do k = 2, nz @@ -213,7 +215,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in 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) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, is-1, ie-is+3, & + tv%eqn_of_state, scale=US%kg_m3_to_R) deltaRhoAtK(:) = deltaRhoAtK(:) - rhoSurf(:) ! Density difference between layer K and surface do i = is-1, ie+1 ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) @@ -282,7 +285,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in uDml(:) = 0.0 ; vDml(:) = 0.0 uDml_slow(:) = 0.0 ; vDml_slow(:) = 0.0 I4dt = 0.25 / (dt_in_T) - g_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_Rho0 = GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z proper_averaging = .not. CS%MLE_use_MLD_ave_bug @@ -316,7 +319,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,rho_ml(:),is-1,ie-is+3,tv%eqn_of_state) + call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,rho_ml(:),is-1,ie-is+3,tv%eqn_of_state, scale=US%kg_m3_to_R) line_is_empty = .true. do i=is-1,ie+1 if (htot_fast(i,j) < MLD_fast(i,j)) then @@ -578,8 +581,8 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, real, dimension(SZI_(G),SZJ_(G)) :: & htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [m3 L2 Z-1 T-2 kg-1 ~> m4 s-2 kg-1] - real :: Rho0(SZI_(G)) ! Potential density relative to the surface [kg m-3] + real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + real :: Rho0(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] real :: p0(SZI_(G)) ! A pressure of 0 [Pa] real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) @@ -616,7 +619,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / (dt_in_T) - g_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z @@ -640,7 +643,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 enddo do k=1,nkml - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,Rho0(:),is-1,ie-is+3,tv%eqn_of_state) + call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,Rho0(:),is-1,ie-is+3,tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is-1,ie+1 Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) htot(i,j) = htot(i,j) + h(i,j,k) @@ -821,7 +824,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! Nonsense values to cause problems when these parameters are not used CS%MLE_MLD_decay_time = -9.e9*US%s_to_T - CS%MLE_density_diff = -9.e9 + CS%MLE_density_diff = -9.e9*US%kg_m3_to_R CS%MLE_tail_dh = -9.e9 CS%MLE_use_PBL_MLD = .false. CS%MLE_MLD_stretch = -9.e9 @@ -867,7 +870,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & "Density difference used to detect the mixed-layer "//& "depth used for the mixed-layer eddy parameterization "//& - "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03) + "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) endif call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& From 3567989df689c4926d5304937f73d07611d5bf75 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Sep 2019 07:27:35 -0400 Subject: [PATCH 112/259] +Rescaled units of set_int_tide_input variables Rescaled the units of variables set in or passed to set_int_tide_input for dimensional consistency testing. All answers are bitwise identical, but the units of several arguments to public interfaces have been changed. --- .../lateral/MOM_internal_tides.F90 | 23 +++---- .../vertical/MOM_diabatic_driver.F90 | 4 +- .../vertical/MOM_internal_tide_input.F90 | 62 +++++++++---------- 3 files changed, 44 insertions(+), 45 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 3c16ae0e57..37a903db85 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -157,10 +157,10 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables !! (needed for wave structure). real, dimension(SZI_(G),SZJ_(G)), intent(in) :: TKE_itidal_input !< The energy input to the - !! internal waves [R m3 s-3 ~> W m-2]. + !! internal waves [R Z3 T-3 ~> W m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read - !! from file [m s-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [s-1]. + !! from file [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Length of time over which these fluxes !! will be applied [s]. type(int_tide_CS), pointer :: CS !< The control structure returned by a @@ -220,8 +220,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & - dt*frac_per_sector*(1.0-CS%q_itides)*US%R_to_kg_m3*TKE_itidal_input(i,j) + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & + US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3*TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo ; enddo elseif (CS%energized_angle <= CS%nAngle) then frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) @@ -230,8 +230,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + & - dt*frac_per_sector*(1.0-CS%q_itides)*US%R_to_kg_m3*TKE_itidal_input(i,j) + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & + US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3*TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo else call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& @@ -357,7 +357,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=jsd,jed ; do i=isd,ied ! Note the 1 m dimensional scale here. Should this be a parameter? I_D_here = 1.0 / (US%Z_to_m*max(G%bathyT(i,j), 1.0*US%m_to_Z)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, vel_btTide(i,j)**2 + & + drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_m**2*US%s_to_T**2*vel_btTide(i,j)**2 + & tot_En(i,j) * I_rho0 * I_D_here)) * I_D_here enddo ; enddo do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied @@ -633,7 +633,7 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: Nb !< Near-bottom stratification [s-1]. + intent(in) :: Nb !< Near-bottom stratification [T-1 ~> s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%nFreq,CS%nMode), & intent(inout) :: Ub !< RMS (over one period) near-bottom horizontal !! mode velocity [L T-1 ~> m s-1]. @@ -677,7 +677,7 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, ! Calculate TKE loss rate; units of [W m-2] here. TKE_loss_tot = q_itides * US%Z_to_m**3*US%s_to_T**3 * TKE_loss_fixed(i,j) * & - US%T_to_s*Nb(i,j) * Ub(i,j,fr,m)**2 + Nb(i,j) * Ub(i,j,fr,m)**2 ! Update energy remaining (this is a pseudo implicit calc) ! (E(t+1)-E(t))/dt = -TKE_loss(E(t+1)/E(t)), which goes to zero as E(t+1) goes to zero @@ -2427,7 +2427,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !Register 2-D energy input into internal tides CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & Time, 'Conversion from barotropic to baroclinic tide, '//& - 'a fraction of which goes into rays', 'W m-2', conversion=US%R_to_kg_m3) + 'a fraction of which goes into rays', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', 'W m-2') diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7da5fa7bed..9cf0fc00da 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -283,7 +283,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn_IGW ! baroclinic internal gravity wave speeds real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp -!### real, dimension(SZI_(G),SZJ_(G)) :: TKE_itidal_input_test ! override of energy input for testing (BDM) real :: dt_in_T ! The time step converted to T units [T ~> s] integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree @@ -357,7 +356,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%use_int_tides) then ! This block provides an interface for the unresolved low-mode internal tide module (BDM). - call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & + call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt_in_T, G, GV, US, & CS%int_tide_input_CSp) cn_IGW(:,:,:) = 0.0 if (CS%uniform_test_cg > 0.0) then @@ -1944,7 +1943,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! [H ~> m or kg m-2] dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. - cTKE, & ! convective TKE requirements for each layer [kg m-3 Z3 T-2 ~> J m-2]. u_h, & ! zonal and meridional velocities at thickness points after v_h ! entrainment [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 89629e0552..2f4f853162 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -37,12 +37,12 @@ module MOM_int_tide_input type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. real :: TKE_itide_max !< Maximum Internal tide conversion - !! available to mix above the BBL [R m3 s-3 ~> W m-2] + !! available to mix above the BBL [R Z3 T-3 ~> W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [Z2 T-1 ~> m2 s-1]. real, allocatable, dimension(:,:) :: TKE_itidal_coef - !< The time-invariant field that enters the TKE_itidal input calculation [R m3 s-2 ~> J m-2]. + !< The time-invariant field that enters the TKE_itidal input calculation [R Z3 T-2 ~> J m-2]. character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site @@ -62,16 +62,16 @@ module MOM_int_tide_input !> This type is used to exchange fields related to the internal tides. type, public :: int_tide_input_type real, allocatable, dimension(:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R m3 s-3 ~> W m-2]. + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. tideamp, & !< The amplitude of the tidal velocities [m s-1]. - Nb !< The bottom stratification [s-1]. + Nb !< The bottom stratification [T-1 ~> s-1]. end type int_tide_input_type contains !> Sets the model-state dependent internal tide energy sources. -subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) +subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt_in_T, G, GV, US, CS) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -83,7 +83,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes type(int_tide_input_type), intent(inout) :: itide !< A structure containing fields related !! to the internal tide sources. - real, intent(in) :: dt !< The time increment [s]. + real, intent(in) :: dt_in_T !< The time increment [T ~> s]. type(int_tide_input_CS), pointer :: CS !< This module's control structure. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -97,10 +97,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) - - integer :: i, j, k, is, ie, js, je, nz - integer :: isd, ied, jsd, jed - + integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed 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 @@ -112,14 +109,14 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Smooth the properties through massless layers. if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt*US%s_to_T, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt_in_T, T_f, S_f, G, GV, larger_h_denom=.true.) endif call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - itide%Nb(i,j) = G%mask2dT(i,j) * US%s_to_T*sqrt(N2_bot(i,j)) + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) itide%TKE_itidal_input(i,j) = min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) enddo ; enddo @@ -131,7 +128,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R + itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 endif enddo ; enddo endif @@ -139,7 +136,8 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (CS%debug) then call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, scale=US%R_to_kg_m3) + call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & + scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) endif if (CS%id_TKE_itidal > 0) call post_data(CS%id_TKE_itidal, itide%TKE_itidal_input, CS%diag) @@ -164,7 +162,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes type(int_tide_input_CS), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy freqency at the - !! ocean bottom [s-2]. + !! ocean bottom [T-2 ~> s-2]. ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. @@ -184,8 +182,9 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) ! density [Z T-2 R-1 ~> m4 s-2 kg-1]. logical :: do_i(SZI_(G)), do_any integer :: i, j, k, is, ie, js, je, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / (GV%Rho0) + G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%Rho0 ! Find the (limited) density jump across each interface. do i=is,ie @@ -277,19 +276,19 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) ! Local variables type(vardesc) :: vd logical :: read_tideamp -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. character(len=20) :: tmpstr character(len=200) :: filename, tideamp_file, h2_file - real :: mask_itidal + real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] real :: max_frac_rough ! The fraction relating the maximum topographic roughness ! to the mean depth [nondim] - real :: utide ! constant tidal amplitude [m s-1] to be used if + real :: utide ! constant tidal amplitude [L T-1 ~> m s-1] to be used if ! tidal amplitude file is not present. - real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height. - real :: kappa_itides ! topographic wavenumber and non-dimensional scaling + real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height [nondim]. + real :: kappa_itides ! topographic wavenumber and non-dimensional scaling [L-1 ~> m-1] real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) @@ -331,7 +330,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0, scale=US%m_s_to_L_T) allocate(itide%Nb(isd:ied,jsd:jed)) ; itide%Nb(:,:) = 0.0 allocate(itide%h2(isd:ied,jsd:jed)) ; itide%h2(:,:) = 0.0 @@ -342,7 +341,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & - units="m-1", default=8.e-4*atan(1.0)) + units="m-1", default=8.e-4*atan(1.0), scale=US%L_to_m) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with n"//& @@ -350,7 +349,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%kg_m3_to_R) + units="W m-2", default=1.0e3, scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -361,7 +360,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, timelevel=1) + call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, timelevel=1, scale=US%m_s_to_L_T) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -402,17 +401,18 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) if (max_frac_rough >= 0.0) & itide%h2(i,j) = min((max_frac_rough*G%bathyT(i,j))**2, itide%h2(i,j)) - ! Compute the fixed part of internal tidal forcing; units are [J m-2] here. - CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& - kappa_itides * US%Z_to_m**2*itide%h2(i,j) * itide%tideamp(i,j)**2 + ! Compute the fixed part of internal tidal forcing; units are [R Z3 T-2 = J m-2] here. + CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor*GV%Rho0*& + kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 enddo ; enddo CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', 'W m-2', conversion=US%R_to_kg_m3) + 'Internal Tide Driven Turbulent Kinetic Energy', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & - 'Bottom Buoyancy Frequency', 's-1') + 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) CS%id_N2_bot = register_diag_field('ocean_model','N2_b_itide',diag%axesT1,Time, & 'Bottom Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2) From ceae8928fde5a4799c8296b9a158470c1134d605 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 30 Sep 2019 12:20:22 -0400 Subject: [PATCH 113/259] Fixing openmp compile - Simple tests produce with threads --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 2 +- .../vertical/MOM_geothermal.F90 | 18 +++++++++--------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 1582b23615..c3c88b4795 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -241,7 +241,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) ! Do this calculation on the extent used in MOM_hor_visc.F90, and ! MOM_tracer.F90 so that no halo update is needed. -!$OMP parallel default(none) shared(is,ie,js,je,Ieq,Jeq,CS) & +!$OMP parallel default(none) shared(is,ie,js,je,Ieq,Jeq,CS,US) & !$OMP private(dx_term,cg1_q,power_2,cg1_u,cg1_v) if (CS%Res_fn_power_visc >= 100) then !$OMP do diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 5fefbf199e..6d81955ab9 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -143,15 +143,6 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) ! resid(i,j) = tv%internal_heat(i,j) ! enddo ; enddo -!$OMP parallel do default(none) shared(is,ie,js,je,G,GV,CS,dt,Irho_cp,nkmb,tv, & -!$OMP p_Ref,h,Angstrom,nz,H_neglect,eb) & -!$OMP private(num_start,heat_rem,do_i,h_geo_rem,num_left,& -!$OMP isj,iej,Rcv_BL,h_heated,heat_avail,k_tgt, & -!$OMP Rcv_tgt,Rcv,dRcv_dT,T2,S2,dRcv_dT_, & -!$OMP dRcv_dS_,heat_in_place,heat_trans, & -!$OMP wt_in_place,dTemp,dRcv,h_transfer,heating, & -!$OMP I_h) - ! Conditionals for tracking diagnostic depdendencies compute_h_old = CS%id_internal_heat_h_tendency > 0 & .or. CS%id_internal_heat_heat_tendency > 0 & @@ -164,6 +155,15 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) if (compute_h_old) h_old(:,:,:) = 0.0 if (compute_T_old) T_old(:,:,:) = 0.0 +!$OMP parallel do default(none) shared(is,ie,js,je,G,GV,CS,dt,Irho_cp,nkmb,tv, & +!$OMP p_Ref,h,Angstrom,nz,H_neglect,eb) & +!$OMP private(num_start,heat_rem,do_i,h_geo_rem,num_left,& +!$OMP isj,iej,Rcv_BL,h_heated,heat_avail,k_tgt, & +!$OMP Rcv_tgt,Rcv,dRcv_dT,T2,S2,dRcv_dT_, & +!$OMP dRcv_dS_,heat_in_place,heat_trans, & +!$OMP wt_in_place,dTemp,dRcv,h_transfer,heating, & +!$OMP I_h) + do j=js,je ! 1. Only work on columns that are being heated. ! 2. Find the deepest layer with any mass. From ef1080bed1acddbe25ae60392e3eeca77c9162d8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Sep 2019 17:19:17 -0400 Subject: [PATCH 114/259] +Rescaled energy units in MOM_internal_tides Rescaled the units of energy, work and other units in MOM_internal_tides and the units of two variables in the transparent wave_structure_CS and in an argument to the subroutine wave_structure. All answers in the existing MOM6_examples test cases are bitwise identical, but there have been changes in the units of some arguments and type elements. --- src/diagnostics/MOM_wave_structure.F90 | 41 +-- .../lateral/MOM_internal_tides.F90 | 237 +++++++++--------- .../vertical/MOM_diabatic_driver.F90 | 2 +- 3 files changed, 148 insertions(+), 132 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index e282b0e43a..80e311de6c 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -43,10 +43,10 @@ module MOM_wave_structure real, allocatable, dimension(:,:,:) :: W_profile !< Vertical profile of w_hat(z), where !! w(x,y,z,t) = w_hat(z)*exp(i(kx+ly-freq*t)) is the full time- - !! varying vertical velocity with w_hat(z) = W0*w_strct(z) [m s-1]. + !! varying vertical velocity with w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. real, allocatable, dimension(:,:,:) :: Uavg_profile !< Vertical profile of the magnitude of horizontal velocity, - !! (u^2+v^2)^0.5, averaged over a period [m s-1]. + !! (u^2+v^2)^0.5, averaged over a period [L T-1 ~> m s-1]. real, allocatable, dimension(:,:,:) :: z_depths !< Depths of layer interfaces [m]. real, allocatable, dimension(:,:,:) :: N2 @@ -102,8 +102,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo type(wave_structure_CS), pointer :: CS !< The control structure returned by a !! previous call to wave_structure_init. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: En !< Internal wave energy density [J m-2]. - logical,optional, intent(in) :: full_halos !< If true, do the calculation + optional, intent(in) :: En !< Internal wave energy density [R Z3 T-2 ~> J m-2] + logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire computational domain. ! Local variables real, dimension(SZK_(G)+1) :: & @@ -147,10 +147,14 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real, dimension(SZK_(G)+1) :: w_strct2, u_strct2 ! squared values real, dimension(SZK_(G)) :: dz ! thicknesses of merged layers (same as Hc I hope) - real, dimension(SZK_(G)+1) :: dWdz_profile ! profile of dW/dz + ! real, dimension(SZK_(G)+1) :: dWdz_profile ! profile of dW/dz real :: w2avg ! average of squared vertical velocity structure funtion - real :: int_dwdz2, int_w2, int_N2w2, KE_term, PE_term, W0 - ! terms in vertically averaged energy equation + real :: int_dwdz2 + real :: int_w2 + real :: int_N2w2 + real :: KE_term ! terms in vertically averaged energy equation + real :: PE_term ! terms in vertically averaged energy equation + real :: W0 ! A vertical velocity magnitude [Z T-1 ~> m s-1] real :: gp_unscaled ! A version of gprime rescaled to [m s-2]. real, dimension(SZK_(G)-1) :: lam_z ! product of eigen value and gprime(k); one value for each ! interface (excluding surface and bottom) @@ -471,18 +475,18 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo w_strct2(:) = w_strct(1:nzm)**2 ! vertical integration with Trapezoidal rule do k=1,nzm-1 - int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1))*dz(k) - int_w2 = int_w2 + 0.5*(w_strct2(K)+w_strct2(K+1))*dz(k) - int_N2w2 = int_N2w2 + 0.5*(w_strct2(K)*N2(K)+w_strct2(K+1)*N2(K+1))*dz(k) + int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * US%m_to_Z*dz(k) + int_w2 = int_w2 + 0.5*(w_strct2(K)+w_strct2(K+1)) * US%m_to_Z*dz(k) + int_N2w2 = int_N2w2 + 0.5*(w_strct2(K)*N2(K)+w_strct2(K+1)*N2(K+1)) * US%m_to_Z*dz(k) enddo ! Back-calculate amplitude from energy equation - if (Kmag2 > 0.0) then - !### This should be simpified to use a single division. - KE_term = 0.25*US%R_to_kg_m3*GV%Rho0*( ((1.0 + f2/freq**2) / Kmag2)*int_dwdz2 + int_w2 ) - PE_term = 0.25*US%R_to_kg_m3*GV%Rho0*( int_N2w2/(US%s_to_T*freq)**2 ) + if (present(En) .and. (freq**2*Kmag2 > 0.0)) then + ! Units here are [R + KE_term = 0.25*GV%Rho0*( ((freq**2 + f2) / (freq**2*Kmag2))*int_dwdz2 + int_w2 ) + PE_term = 0.25*GV%Rho0*( int_N2w2 / (US%s_to_T*freq)**2 ) if (En(i,j) >= 0.0) then - W0 = sqrt( En(i,j)/(KE_term + PE_term) ) + W0 = sqrt( En(i,j) / (KE_term + PE_term) ) else call MOM_error(WARNING, "wave_structure: En < 0.0; setting to W0 to 0.0") print *, "En(i,j)=", En(i,j), " at ig=", ig, ", jg=", jg @@ -490,13 +494,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo endif ! Calculate actual vertical velocity profile and derivative W_profile(:) = W0*w_strct(:) - dWdz_profile(:) = W0*u_strct(:) + ! dWdz_profile(:) = W0*u_strct(:) ! Calculate average magnitude of actual horizontal velocity over a period - !### This should be simpified to use a single division. - Uavg_profile(:) = abs(dWdz_profile(:)) * sqrt((1.0 + f2/freq**2) / (2.0*Kmag2)) + Uavg_profile(:) = US%Z_to_L*abs(W0*u_strct(:)) * sqrt((freq**2 + f2) / (2.0*freq**2*Kmag2)) else W_profile(:) = 0.0 - dWdz_profile(:) = 0.0 + ! dWdz_profile(:) = 0.0 Uavg_profile(:) = 0.0 endif diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 37a903db85..09fb07eae1 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -67,28 +67,29 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss - !< energy lost due to misc background processes [W m-2] + !< energy lost due to misc background processes [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_quad_loss - !< energy lost due to quadratic bottom drag [W m-2] + !< energy lost due to quadratic bottom drag [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss - !< energy lost due to wave breaking [W m-2] + !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - !< fixed part of the energy lost due to small-scale drag - !! [kg m L-2 Z-1 ~> kg m-2] here; will be multiplied by N and En to get into [W m-2] + !< Fixed part of the energy lost due to small-scale drag [R L-2 Z3 ~> kg m-2] here; + !! This will be multiplied by N and the squared near-bottom velocity to get + !! the energy losses in [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss - !< energy lost due to small-scale wave drag [W m-2] + !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc bakground processes, - !! summed over angle, frequency and mode [W m-2] + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, - !! summed over angle, frequency and mode [W m-2] + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag, - !! summed over angle, frequency and mode [W m-2] + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, - !! summed over angle, frequency and mode [W m-2] + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, - !! summed over angle, frequency and mode [W m-2] + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real :: q_itides !< fraction of local dissipation [nondim] - real :: En_sum !< global sum of energy for use in debugging + real :: En_sum !< global sum of energy for use in debugging [R Z3 T-2 ~> J m-2] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. character(len=200) :: inputdir !< directory to look for coastline angle file real :: decay_rate !< A constant rate at which internal tide energy is @@ -103,7 +104,8 @@ module MOM_internal_tides logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. real, dimension(:,:,:,:,:), pointer :: En => NULL() - !< The internal wave energy density as a function of (i,j,angle,frequency,mode) [J m-2] + !< The internal wave energy density as a function of (i,j,angle,frequency,mode) + !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] real, dimension(:,:,:), pointer :: En_restart => NULL() !< The internal wave energy density as a function of (i,j,angle); temporary for restart real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. @@ -147,7 +149,7 @@ module MOM_internal_tides !> Calls subroutines in this file that are needed to refract, propagate, !! and dissipate energy density of the internal tide. -subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & +subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in_T, & G, GV, US, 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. @@ -161,8 +163,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read !! from file [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. - real, intent(in) :: dt !< Length of time over which these fluxes - !! will be applied [s]. + real, intent(in) :: dt_in_T !< Length of time over which to advance + !! the internal tides [T ~> s]. type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. real, dimension(SZI_(G),SZJ_(G),CS%nMode), & @@ -172,28 +174,30 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real, dimension(SZI_(G),SZJ_(G),2) :: & test real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & - tot_En_mode, & ! energy summed over angles only + tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & flux_heat_y, & flux_prec_y real, dimension(SZI_(G),SZJ_(G)) :: & - tot_En, & ! energy summed over angles, modes, frequencies + tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_allprocesses_loss, & - ! energy loss rates summed over angle, freq, and mode - drag_scale, & ! bottom drag scale, s-1 + ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] + drag_scale, & ! bottom drag scale [T-1 ~> s-1] itidal_loss_mode, allprocesses_loss_mode - ! energy loss rates for a given mode and frequency (summed over angles) - real :: frac_per_sector, f2, I_rho0, I_D_here, Kmag2 + ! energy loss rates for a given mode and frequency (summed over angles) [R Z3 T-3 ~> W m-2] + real :: frac_per_sector, f2, Kmag2 + real :: I_D_here ! The inverse of the local depth [Z-1 ~> m-1] + real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] real :: freq2 ! The frequency squared [T-2 ~> s-2] real :: c_phase ! The phase speed [m s-1] - real :: loss_rate, Fr2_max + real :: loss_rate ! An energy loss rate [T-1 ~> s-1] + real :: Fr2_max real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] - real :: dt_in_T ! The timestep [T ~> s] - real :: En_new, En_check ! for debugging - real :: En_initial, Delta_E_check ! for debugging - real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! for debugging + real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] + real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] + real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] character(len=160) :: mesg ! The text of an error message integer :: a, m, fr, i, j, is, ie, js, je, isd, ied, jsd, jed, nAngle, nzm integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) @@ -202,8 +206,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle - I_rho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) - dt_in_T = US%s_to_T*dt + I_rho0 = 1.0 / (GV%Rho0) +! dt_in_T = US%s_to_T*dt cn_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** @@ -220,8 +224,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3*TKE_itidal_input(i,j) + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt_in_T*frac_per_sector*(1.0-CS%q_itides) * & + TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo ; enddo elseif (CS%energized_angle <= CS%nAngle) then frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) @@ -230,8 +234,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3*TKE_itidal_input(i,j) + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt_in_T*frac_per_sector*(1.0-CS%q_itides) * & + TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo else call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& @@ -334,8 +338,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [Wm-2] - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt *CS%decay_rate) ! implicit update + CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt_in_T * CS%decay_rate) ! implicit update enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later @@ -356,15 +360,15 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%apply_bottom_drag) then do j=jsd,jed ; do i=isd,ied ! Note the 1 m dimensional scale here. Should this be a parameter? - I_D_here = 1.0 / (US%Z_to_m*max(G%bathyT(i,j), 1.0*US%m_to_Z)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_m**2*US%s_to_T**2*vel_btTide(i,j)**2 + & + I_D_here = 1.0 / (max(G%bathyT(i,j), 1.0*US%m_to_Z)) + drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & tot_En(i,j) * I_rho0 * I_D_here)) * I_D_here enddo ; enddo do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt *drag_scale(i,j)) ! implicit update + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt_in_T * drag_scale(i,j)) ! implicit update enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later @@ -394,8 +398,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=jsd,jed ; do i=isd,ied id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging nzm = CS%wave_structure_CSp%num_intfaces(i,j) - Ub(i,j,fr,m) = US%m_s_to_L_T * CS%wave_structure_CSp%Uavg_profile(i,j,nzm) - Umax(i,j,fr,m) = US%m_s_to_L_T * maxval(CS%wave_structure_CSp%Uavg_profile(i,j,1:nzm)) + Ub(i,j,fr,m) = CS%wave_structure_CSp%Uavg_profile(i,j,nzm) + Umax(i,j,fr,m) = maxval(CS%wave_structure_CSp%Uavg_profile(i,j,1:nzm)) enddo ; enddo ! i-loop, j-loop enddo ; enddo ! fr-loop, m-loop endif ! apply_wave or _Froude_drag (Ub or Umax needed) @@ -403,7 +407,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step call itidal_lowmode_loss(G, US, CS, Nb, Ub, CS%En, CS%TKE_itidal_loss_fixed, & - CS%TKE_itidal_loss, dt, full_halos=.false.) + CS%TKE_itidal_loss, dt_in_T, full_halos=.false.) endif ! Check for En<0 - for debugging, delete later do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -439,17 +443,17 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (Fr2_max > 1.0) then En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging ! Calculate effective decay rate [s-1] if breaking occurs over a time step - loss_rate = (1/Fr2_max - 1.0)/dt + loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt_in_T) do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) ! Update energy En_new = CS%En(i,j,a,fr,m)/Fr2_max ! for debugging - En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt ! for debugging + En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt_in_T ! for debugging ! Re-scale (reduce) energy due to breaking CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max ! Check (for debugging only) - if (abs(En_new - En_check) > 1e-10) then + if (abs(En_new - En_check) > 1e-10*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) then call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & all_print=.true.) write(mesg,*) "En_new=", En_new , "En_check=", En_check @@ -458,7 +462,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & enddo ! Check (for debugging) Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) - TKE_Froude_loss_check = abs(Delta_E_check)/dt + TKE_Froude_loss_check = abs(Delta_E_check)/dt_in_T TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot) > 1e-10) then call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & @@ -592,13 +596,15 @@ subroutine sum_En(G, CS, En, label) type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & - intent(in) :: En !< The energy density of the internal tides [J m-2]. + intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables + real :: En_sum ! The total energy [R Z3 T-2 ~> J m-2] + real :: tmpForSumming integer :: m,fr,a - real :: En_sum, tmpForSumming, En_sum_diff, En_sum_pdiff - character(len=160) :: mesg ! The text of an error message - real :: days + ! real :: En_sum_diff, En_sum_pdiff + ! character(len=160) :: mesg ! The text of an error message + ! real :: days En_sum = 0.0 tmpForSumming = 0.0 @@ -606,13 +612,13 @@ subroutine sum_En(G, CS, En, label) tmpForSumming = global_area_mean(En(:,:,a),G)*G%areaT_global En_sum = En_sum + tmpForSumming enddo - En_sum_diff = En_sum - CS%En_sum - if (CS%En_sum /= 0.0) then - En_sum_pdiff= (En_sum_diff/CS%En_sum)*100.0 - else - En_sum_pdiff= 0.0 - endif CS%En_sum = En_sum + !En_sum_diff = En_sum - CS%En_sum + !if (CS%En_sum /= 0.0) then + ! En_sum_pdiff= (En_sum_diff/CS%En_sum)*100.0 + !else + ! En_sum_pdiff= 0.0 + !endif !! Print to screen !if (is_root_pe()) then ! days = time_type_to_real(CS%Time) / 86400.0 @@ -627,7 +633,7 @@ end subroutine sum_En !> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) +subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt_in_T, full_halos) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), pointer :: CS !< The control structure returned by a @@ -638,30 +644,31 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, intent(inout) :: Ub !< RMS (over one period) near-bottom horizontal !! mode velocity [L T-1 ~> m s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [kg m L-2 Z-1 ~> kg m-2] + intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R L-2 Z3 ~> kg m-2] !! (rho*kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(inout) :: En !< Energy density of the internal waves [J m-2]. + intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(out) :: TKE_loss !< Energy loss rate [W m-2] + intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] !! (q*rho*kappa*h^2*N*U^2). - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt_in_T !< Time increment [T ~> s]. logical,optional, intent(in) :: full_halos !< If true, do the calculation over the !! entirecomputational domain. ! Local variables integer :: j,i,m,fr,a, is, ie, js, je - real :: En_tot ! energy for a given mode, frequency, and point summed over angles - real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles + real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] + real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] real :: TKE_sum_check ! temporary for check summing real :: frac_per_sector ! fraction of energy in each wedge real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is ! assumed to stay in propagating mode for now - BDM) - real :: loss_rate ! approximate loss rate for implicit calc [s-1] - real, parameter :: En_negl = 1e-30 ! negilibly small number to prevent division by zero + real :: loss_rate ! approximate loss rate for implicit calc [T-1 ~> s-1] + real :: En_negl ! negilibly small number to prevent division by zero is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec q_itides = CS%q_itides + En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 if (present(full_halos)) then ; if (full_halos) then is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed @@ -675,9 +682,8 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, En_tot = En_tot + En(i,j,a,fr,m) enddo - ! Calculate TKE loss rate; units of [W m-2] here. - TKE_loss_tot = q_itides * US%Z_to_m**3*US%s_to_T**3 * TKE_loss_fixed(i,j) * & - Nb(i,j) * Ub(i,j,fr,m)**2 + ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. + TKE_loss_tot = q_itides * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 ! Update energy remaining (this is a pseudo implicit calc) ! (E(t+1)-E(t))/dt = -TKE_loss(E(t+1)/E(t)), which goes to zero as E(t+1) goes to zero @@ -685,8 +691,8 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, do a=1,CS%nAngle frac_per_sector = En(i,j,a,fr,m)/En_tot TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! Wm-2 - loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! s-1 - En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) + loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] + En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt_in_T*loss_rate) enddo else ! no loss if no energy @@ -698,8 +704,8 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, ! do a=1,CS%nAngle ! frac_per_sector = En(i,j,a,fr,m)/En_tot ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then - ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt + ! if (TKE_loss(i,j,a,fr,m)*dt_in_T <= En(i,j,a,fr,m))then + ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt_in_T ! else ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than avalable, "// & ! " setting En to zero.", all_print=.true.) @@ -727,7 +733,7 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) !! previous call to int_tide_init. character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified - !! mechanism [W m-2]. + !! mechanism [R Z3 T-3 ~> W m-2]. if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet @@ -744,7 +750,7 @@ subroutine refract(En, cn, freq, dt_in_T, G, US, NAngle, use_PPMang) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [J m-2 radian-1]. + !! [R Z3 T-2 ~> J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. @@ -874,11 +880,11 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt_in_T, halo_ang) integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: En2d !< The internal gravity wave energy density as a - !! function of angular resolution [J m-2 radian-1]. + !! function of angular resolution [R Z3 T-2 ~> J m-2]. real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: CFL_ang !< The CFL number of the energy advection across angles real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux - !! across angles [J m-2 radian-1]. + !! across angles [R Z3 T-2 ~> J m-2]. ! Local variables real :: flux real :: u_ang @@ -955,11 +961,11 @@ subroutine propagate(En, cn, freq, dt_in_T, G, US, CS, NAngle) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [J m-2 radian-1]. + !! [R Z3 T-2 ~> J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. - real, intent(in) :: dt_in_T !< Time step [T ~> s]. + real, intent(in) :: dt_in_T !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. @@ -1079,7 +1085,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt_in_T, type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(inout) :: En !< The energy density integrated over an angular - !! band [W m-2], intent in/out. + !! band [R Z3 T-2 ~> J m-2], intent in/out. real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & intent(in) :: speed !< The magnitude of the group velocity at the cell !! corner points [L T-1 ~> m s-1]. @@ -1112,8 +1118,8 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt_in_T, real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x,y ! coordinates of cell corners real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx,Idy ! inverse of dx,dy at cell corners real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx,dy ! dx,dy at cell corners - real, dimension(2) :: E_new ! energy in cell after advection for subray; set size here to - ! define Nsubrays - this should be made an input option later! + real, dimension(2) :: E_new ! Energy in cell after advection for subray [R Z3 T-2 ~> J m-2]; set size + ! here to define Nsubrays - this should be made an input option later! ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh TwoPi = (8.0*atan(1.0)) @@ -1346,7 +1352,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt_in_T, G, US, Nangle, CS, LB !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [J m-2], intent in/out. + !! band [R Z3 T-2 ~> J m-2], intent in/out. real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & intent(in) :: speed_x !< The magnitude of the group velocity at the !! Cu points [L T-1 ~> m s-1]. @@ -1360,7 +1366,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt_in_T, G, US, Nangle, CS, LB type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! Left and right face energy densities [J m-2]. + EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & flux_x ! The internal wave energy flux [J s-1]. real, dimension(SZIB_(G)) :: & @@ -1421,7 +1427,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt_in_T, G, US, Nangle, CS, LB !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [J m-2], intent in/out. + !! band [R Z3 T-2 ~> J m-2], intent in/out. real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & intent(in) :: speed_y !< The magnitude of the group velocity at the !! Cv points [L T-1 ~> m s-1]. @@ -1435,7 +1441,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt_in_T, G, US, Nangle, CS, LB type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! South and north face energy densities [J m-2]. + EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & flux_y ! The internal wave energy flux [J s-1]. real, dimension(SZI_(G)) :: & @@ -1501,12 +1507,12 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes - !! [J m-2]. + !! [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction - !! [J m-2]. + !! [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction - !! [J m-2]. - real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [L2 T-1 J m-2 ~> J s-1]. + !! [R Z3 T-2 ~> J m-2]. + real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [R Z3 L2 T-3 ~> J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-index to work on. @@ -1545,12 +1551,12 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Energy density used to calculate the - !! fluxes [J m-2]. + !! fluxes [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hL !< Left- Energy densities in the - !! reconstruction [J m-2]. + !! reconstruction [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hR !< Right- Energy densities in the - !! reconstruction [J m-2]. - real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [L2 T-1 J m-2 ~> J s-1]. + !! reconstruction [R Z3 T-2 ~> J m-2]. + real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [R Z3 L2 T-3 ~> J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: J !< The j-index to work on. @@ -1592,7 +1598,7 @@ subroutine reflect(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [J m-2 radian-1]. + !! [R Z3 T-2 ~> J m-2]. type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. @@ -1706,7 +1712,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [J m-2 radian-1]. + !! [R Z3 T-2 ~> J m-2]. type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. @@ -1724,7 +1730,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real :: Angle_size ! size of beam wedge (rad) real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator real, dimension(1:NAngle) :: cos_angle, sin_angle - real :: En_tele ! energy to be "teleported" + real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] character(len=160) :: mesg ! The text of an error message integer :: i, j, a !integer :: isd, ied, jsd, jed ! start and end local indices on data domain @@ -1805,7 +1811,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a !! function of space, angular orientation, frequency, - !! and vertical mode [J m-2 radian-1]. + !! and vertical mode [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: test !< An x-unit vector that has been passed through !! the halo updates, to enable the rotation of the @@ -2220,7 +2226,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & "The rate at which internal tide energy is lost to the "//& - "interior ocean internal wave field.", units="s-1", default=0.0) + "interior ocean internal wave field.", & + units="s-1", default=0.0, scale=US%T_to_s) call get_param(param_file, mdl, "INTERNAL_TIDE_VOLUME_BASED_CFL", CS%vol_CFL, & "If true, use the ratio of the open face lengths to the "//& "tracer cell areas when estimating CFL numbers in the "//& @@ -2305,9 +2312,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict rms topo to 10 percent of column depth. h2(i,j) = min(0.01*(G%bathyT(i,j))**2, h2(i,j)) - ! Compute the fixed part; units are [kg m-2] here - ! will be multiplied by N and En to get into [W m-2] - CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*US%R_to_kg_m3*GV%Rho0 * US%L_to_Z*kappa_itides * h2(i,j) + ! Compute the fixed part; units are [R L-2 Z3 ~> kg m-2] here + ! will be multiplied by N and the squared near-bottom velocity to get into [R Z3 T-3 ~> W m-2] + CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0 * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo deallocate(h2) @@ -2420,10 +2427,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Register 2-D energy density (summed over angles, freq, modes) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & - Time, 'Internal tide total energy density', 'J m-2') + Time, 'Internal tide total energy density', & + 'J m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) ! Register 2-D drag scale used for quadratic bottom drag CS%id_itide_drag = register_diag_field('ocean_model', 'ITide_drag', diag%axesT1, & - Time, 'Interior and bottom drag internal tide decay timescale', 's-1') + Time, 'Interior and bottom drag internal tide decay timescale', 's-1', conversion=US%s_to_T) !Register 2-D energy input into internal tides CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & Time, 'Conversion from barotropic to baroclinic tide, '//& @@ -2431,15 +2439,20 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & - Time, 'Internal tide energy loss to background drag', 'W m-2') + Time, 'Internal tide energy loss to background drag', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) CS%id_tot_quad_loss = register_diag_field('ocean_model', 'ITide_tot_quad_loss', diag%axesT1, & - Time, 'Internal tide energy loss to bottom drag', 'W m-2') + Time, 'Internal tide energy loss to bottom drag', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) CS%id_tot_itidal_loss = register_diag_field('ocean_model', 'ITide_tot_itidal_loss', diag%axesT1, & - Time, 'Internal tide energy loss to wave drag', 'W m-2') + Time, 'Internal tide energy loss to wave drag', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & - Time, 'Internal tide energy loss to wave breaking', 'W m-2') + Time, 'Internal tide energy loss to wave breaking', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & - Time, 'Internal tide energy loss summed over all processes', 'W m-2') + Time, 'Internal tide energy loss summed over all processes', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) allocate(CS%id_En_mode(CS%nFreq,CS%nMode)) ; CS%id_En_mode(:,:) = -1 allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode)) ; CS%id_En_ang_mode(:,:) = -1 @@ -2462,14 +2475,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'J m-2') + diag%axesT1, Time, var_descript, 'J m-2', conversion=US%R_to_kg_m3*US%Z_to_m**2*US%s_to_T**3) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy density for each freq and mode write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'J m-2 band-1') + axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%R_to_kg_m3*US%Z_to_m**2*US%s_to_T**3) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D energy loss (summed over angles) for each freq and mode @@ -2477,13 +2490,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2') + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m CS%id_allprocesses_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2') + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy loss for each freq and mode @@ -2491,7 +2504,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'W m-2 band-1') + axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D period-averaged near-bottom horizonal velocity for each freq and mode diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 9cf0fc00da..48318ff398 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -366,7 +366,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif call propagate_int_tide(h, tv, cn_IGW, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, dt, G, GV, US, CS%int_tide_CSp) + CS%int_tide_input%Nb, dt_in_T, G, GV, US, CS%int_tide_CSp) if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides From 1865f4f324de12a116601ba1004238645736d8e3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Sep 2019 19:03:34 -0400 Subject: [PATCH 115/259] (*)+Rescaled MEKE source element units in MEKE_type Rescaled units of MEKE source elements in MEKE_type, and made slight code modifications when MEKE_GM_SRC_ALT is true to ensure that the documented units are always used. Also corrected a bug in omitting looping over layers with the same setting, which will change answers when MEKE_GM_SRC_ALT is true. All answers are bitwise identical in the MOM6-examples test cases. --- src/parameterizations/lateral/MOM_MEKE.F90 | 25 ++++---- .../lateral/MOM_MEKE_types.F90 | 6 +- .../lateral/MOM_hor_visc.F90 | 19 +++--- .../lateral/MOM_thickness_diffuse.F90 | 64 +++++++++---------- 4 files changed, 56 insertions(+), 58 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index cdaa8151c9..2b9a4b9bfd 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -182,11 +182,11 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (associated(MEKE%mom_src)) & - call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (associated(MEKE%GME_snk)) & - call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (associated(MEKE%GM_src)) & - call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (associated(MEKE%MEKE)) call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T) call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m) @@ -295,14 +295,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (associated(MEKE%mom_src)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) + src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*US%R_to_kg_m3*US%Z_to_m*MEKE%mom_src(i,j) enddo ; enddo endif if (associated(MEKE%GME_snk)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_GMECoeff*I_mass(i,j)*MEKE%GME_snk(i,j) + src(i,j) = src(i,j) - CS%MEKE_GMECoeff*I_mass(i,j)*US%R_to_kg_m3*US%Z_to_m*MEKE%GME_snk(i,j) enddo ; enddo endif @@ -310,13 +310,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%GM_src_alt) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_GMcoeff*MEKE%GM_src(i,j) / & - MAX(1.0, G%bathyT(i,j)) !### 1.0 seems to be a hard-coded dimensional constant (1 m?). + src(i,j) = src(i,j) - CS%MEKE_GMcoeff*US%Z_to_m*MEKE%GM_src(i,j) / & + (GV%Rho0 * MAX(1.0*US%m_to_Z, G%bathyT(i,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) + src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*US%R_to_kg_m3*US%Z_to_m*MEKE%GM_src(i,j) enddo ; enddo endif endif @@ -1150,13 +1150,16 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & 'MEKE decay rate', 's-1', conversion=US%s_to_T) CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & - 'MEKE energy available from thickness mixing', 'W m-2', conversion=US%L_to_m**2*US%s_to_T**3) + 'MEKE energy available from thickness mixing', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (.not. associated(MEKE%GM_src)) CS%id_GM_src = -1 CS%id_mom_src = register_diag_field('ocean_model', 'MEKE_mom_src',diag%axesT1, Time, & - 'MEKE energy available from momentum', 'W m-2', conversion=US%L_to_m**2*US%s_to_T**3) + 'MEKE energy available from momentum', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (.not. associated(MEKE%mom_src)) CS%id_mom_src = -1 CS%id_GME_snk = register_diag_field('ocean_model', 'MEKE_GME_snk',diag%axesT1, Time, & - 'MEKE energy lost to GME backscatter', 'W m-2', conversion=US%L_to_m**2*US%s_to_T**3) + 'MEKE energy lost to GME backscatter', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (.not. associated(MEKE%GME_snk)) CS%id_GME_snk = -1 CS%id_Le = register_diag_field('ocean_model', 'MEKE_Le', diag%axesT1, Time, & 'Eddy mixing length used in the MEKE derived eddy diffusivity', 'm', conversion=US%L_to_m) diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index 33f8f5d1b2..01a602157a 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -9,9 +9,9 @@ module MOM_MEKE_types ! Variables real, dimension(:,:), pointer :: & MEKE => NULL(), & !< Vertically averaged eddy kinetic energy [L2 T-2 ~> m2 s-2]. - GM_src => NULL(), & !< MEKE source due to thickness mixing (GM) [kg m-2 L2 T-3 ~> W m-2]. - mom_src => NULL(),& !< MEKE source from lateral friction in the momentum equations [kg m-2 L2 T-3 ~> W m-2]. - GME_snk => NULL(),& !< MEKE sink from GME backscatter in the momentum equations [kg m-2 L2 T-3 ~> W m-2]. + GM_src => NULL(), & !< MEKE source due to thickness mixing (GM) [R Z L2 T-3 ~> W m-2]. + mom_src => NULL(),& !< MEKE source from lateral friction in the momentum equations [R Z L2 T-3 ~> W m-2]. + GME_snk => NULL(),& !< MEKE sink from GME backscatter in the momentum equations [R Z L2 T-3 ~> W m-2]. Kh => NULL(), & !< The MEKE-derived lateral mixing coefficient [L2 T-1 ~> m2 s-1]. Kh_diff => NULL(), & !< Uses the non-MEKE-derived thickness diffusion coefficient to diffuse !! MEKE [L2 T-1 ~> m2 s-1]. diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 7384c30a35..a62969e3f0 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1369,8 +1369,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_GME) then do j=js,je ; do i=is,ie ! MEKE%mom_src now is sign definite because it only uses the dissipation - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (US%R_to_kg_m3*US%Z_to_m) * & - MAX(FrictWork_diss(i,j,k), FrictWorkMax(i,j,k)) + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + MAX(FrictWork_diss(i,j,k), FrictWorkMax(i,j,k)) enddo ; enddo else ! use_GME if (MEKE%backscatter_Ro_c /= 0.) then @@ -1397,7 +1396,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, RoScl = Sh_F_pow / (1.0 + Sh_F_pow) ! = 1 - f^n/(f^n+c*D^n) endif endif - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * (US%R_to_kg_m3*US%Z_to_m) * ( & + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( & ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & +0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J))*( & @@ -1415,18 +1414,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo else ! MEKE%backscatter_Ro_c do j=js,je ; do i=is,ie - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (US%R_to_kg_m3*US%Z_to_m) * FrictWork(i,j,k) + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) enddo ; enddo endif ! MEKE%backscatter_Ro_c endif !use GME - if (CS%use_GME .and. associated(MEKE)) then - if (associated(MEKE%GME_snk)) then - do j=js,je ; do i=is,ie - MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + (US%R_to_kg_m3*US%Z_to_m) * FrictWork_GME(i,j,k) - enddo ; enddo - endif - endif + if (CS%use_GME .and. associated(MEKE)) then ; if (associated(MEKE%GME_snk)) then + do j=js,je ; do i=is,ie + MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + FrictWork_GME(i,j,k) + enddo ; enddo + endif ; endif endif ; endif ! find_FrictWork and associated(mom_src) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d30c2baa5a..0aa79098d0 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -73,7 +73,7 @@ module MOM_thickness_diffuse logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the GM source term. type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics - real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [W m-2] + real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] real, pointer :: diagSlopeY(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] @@ -580,8 +580,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, S_v, & ! Salinity on the interface at the v-point [ppt]. pres_v ! Pressure on the interface at the v-point [Pa]. real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness - real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [ kg L2 s-3 ~> W ] - real :: Work_h ! The work averaged over an h-cell [W m-2]. + real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W ] + real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] ! The calculation is equal to h * S^2 * N^2 * kappa_GM. real :: I4dt ! 1 / 4 dt [T-1 ~> s-1]. @@ -625,8 +625,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. real :: dz_neglect ! A thickness [Z ~> m], that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. - real :: G_scale ! The gravitational acceleration times some unit conversion - ! factors [kg T R-1 Z-1 H-1 s-3 ~> m s-2 or m4 kg-1 s-2]. + real :: G_scale ! The gravitational acceleration times a unit conversion + ! factor [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. @@ -644,7 +644,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, I4dt = 0.25 / (dt_in_T) I_slope_max2 = 1.0 / (CS%slope_max**2) - G_scale = GV%g_Earth*US%L_to_m**2*US%s_to_T**3 * GV%H_to_m * US%R_to_kg_m3 + G_scale = GV%g_Earth * GV%H_to_Z + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 dz_neglect = GV%H_subroundoff*GV%H_to_Z G_rho0 = GV%g_Earth / GV%Rho0 @@ -1269,27 +1270,24 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, endif - !if (find_work) then ; do j=js,je ; do i=is,ie ; do k=nz,1,-1 if (find_work) then ; do j=js,je ; do i=is,ie ! Note that the units of Work_v and Work_u are W, while Work_h is W m-2. Work_h = 0.5 * G%IareaT(i,j) * & ((Work_u(I-1,j) + Work_u(I,j)) + (Work_v(i,J-1) + Work_v(i,J))) - PE_release_h = -0.25*(KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & - Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + & - Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & - Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) if (associated(CS%GMwork)) CS%GMwork(i,j) = Work_h - if (associated(MEKE)) then ; if (associated(MEKE%GM_src)) then - if (CS%GM_src_alt) then - !### This expression is in [L2 T-3 m ~> m3 s-3] - MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%L_to_m**2*US%m_to_Z*PE_release_h - else - !### This expression is in [L2 T-3 kg m-2 ~> kg s-3] - MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%m_to_L**2*US%T_to_s**3*Work_h - endif + if (associated(MEKE) .and. .not.CS%GM_src_alt) then ; if (associated(MEKE%GM_src)) then + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + Work_h endif ; endif - !enddo ; enddo ; enddo ; endif enddo ; enddo ; endif + if (find_work .and. CS%GM_src_alt .and. associated(MEKE)) then ; if (associated(MEKE%GM_src)) then + do j=js,je ; do i=is,ie ; do k=nz,1,-1 + PE_release_h = -0.25*(KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & + Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + & + Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & + Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%L_to_Z**2 * GV%Rho0 * PE_release_h + enddo ; enddo ; enddo + endif ; endif if (CS%id_slope_x > 0) call post_data(CS%id_slope_x, CS%diagSlopeX, CS%diag) if (CS%id_slope_y > 0) call post_data(CS%id_slope_y, CS%diagSlopeY, CS%diag) @@ -1889,11 +1887,11 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) x_cell_method='sum', v_extensive=.true.) if (CS%id_vhGM > 0) call safe_alloc_ptr(CDp%vhGM,G%isd,G%ied,G%JsdB,G%JedB,G%ke) - CS%id_GMwork = register_diag_field('ocean_model', 'GMwork', diag%axesT1, Time, & - 'Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & - 'W m-2', cmor_field_name='tnkebto', & - cmor_long_name='Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection',& - cmor_standard_name='tendency_of_ocean_eddy_kinetic_energy_content_due_to_parameterized_eddy_advection') + CS%id_GMwork = register_diag_field('ocean_model', 'GMwork', diag%axesT1, Time, & + 'Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3, cmor_field_name='tnkebto', & + cmor_long_name='Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & + cmor_standard_name='tendency_of_ocean_eddy_kinetic_energy_content_due_to_parameterized_eddy_advection') 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, & @@ -1902,13 +1900,13 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) CS%id_KH_v = register_diag_field('ocean_model', 'KHTH_v', diag%axesCvi, Time, & 'Parameterized mesoscale eddy advection diffusivity at V-point', & 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KH_t = register_diag_field('ocean_model', 'KHTH_t', diag%axesTL, Time, & - 'Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', & - 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & - 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_t = register_diag_field('ocean_model', 'KHTH_t', diag%axesTL, Time, & + 'Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', & + 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & + 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)', & @@ -1916,7 +1914,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) CS%id_KH_v1 = register_diag_field('ocean_model', 'KHTH_v1', diag%axesCv1, Time, & 'Parameterized mesoscale eddy advection diffusivity at V-points (2-D)', & 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KH_t1 = register_diag_field('ocean_model', 'KHTH_t1', diag%axesT1, Time,& + CS%id_KH_t1 = register_diag_field('ocean_model', 'KHTH_t1', diag%axesT1, Time, & 'Parameterized mesoscale eddy advection diffusivity at T-points (2-D)', & 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) From b6dfa49c1a45ab2ff1da8dfa8f22a6f0ef17fa27 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 1 Oct 2019 00:42:47 -0400 Subject: [PATCH 116/259] Use popcnt intrinsic for bitcount Profiling of the test suite showed a large amount of time (nearly 1/3) devoted to computing of bitcounts used as checksums for diagnostics. This patch replaces the bit loop with the popcnt intrinsic, which produces the same result and uses the hardware assembly instruction when available (e.g. popcnt in x86). This change appears to have reduced the runtime of the test suite from 4.5 minutes to under 3 minutes. --- src/framework/MOM_checksums.F90 | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index c6a23667db..34390017ee 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -1849,20 +1849,12 @@ end subroutine chksum_error !> Does a bitcount of a number by first casting to an integer and then using BTEST !! to check bit by bit integer function bitcount(x) - real :: x !< Number to be bitcount + real, intent(in) :: x !< Number to be bitcount - ! Local variables - integer(kind(x)) :: y !< Store the integer representation of the memory used by x - integer :: bit - - bitcount = 0 - y = transfer(x,y) - - ! Fortran standard says that bit indexing start at 0 - do bit = 0, bit_size(y)-1 - if (BTEST(y,bit)) bitcount = bitcount+1 - enddo + integer, parameter :: xk = kind(x) !< Kind type of x + ! NOTE: Assumes that reals and integers of kind=xk are the same size + bitcount = popcnt(transfer(x, 1_xk)) end function bitcount end module MOM_checksums From 401ea2bd02a2e4040b6fc5c8bcfa623ccc5f5853 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Oct 2019 06:42:16 -0400 Subject: [PATCH 117/259] Rescaled density units in MOM_MEKE.F90 Rescaled density units in MOM_MEKE.F90 for dimensional consistency testing. All answers are bitwise identical. --- src/parameterizations/lateral/MOM_MEKE.F90 | 59 ++++++++++++---------- 1 file changed, 31 insertions(+), 28 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 2b9a4b9bfd..e4d5cfef39 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -113,8 +113,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - mass, & ! The total mass of the water column [kg m-2]. - I_mass, & ! The inverse of mass [m2 kg-1]. + mass, & ! The total mass of the water column [R Z ~> kg m-2]. + I_mass, & ! The inverse of mass [R-1 Z-1 ~> m2 kg-1]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. ! MEKE_GM_src, & ! The MEKE source from thickness mixing [m2 s-3]. @@ -151,9 +151,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h real :: cdrag2 real :: advFac ! The product of the advection scaling factor and some unit conversion ! factors divided by the timestep [m H-1 T-1 ~> s-1 or m3 kg-1 s-1] - real :: mass_neglect ! A negligible mass [kg m-2]. + real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. - real :: Rho0 ! A density used to convert mass to distance [kg m-3]. + real :: Rho0 ! A density used to convert mass to distance [R ~> kg m-3]. real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). logical :: use_drag_rate ! Flag to indicate drag_rate is finite @@ -193,8 +193,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif sdt = US%s_to_T*dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping - Rho0 = GV%H_to_kg_m2 * GV%m_to_H - mass_neglect = GV%H_to_kg_m2 * GV%H_subroundoff + Rho0 = GV%Rho0 + mass_neglect = GV%H_to_RZ * GV%H_subroundoff cdrag2 = CS%cdrag**2 ! With a depth-dependent (and possibly strong) damping, it seems @@ -262,7 +262,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js-1,je+1 do i=is-1,ie+1 ; mass(i,j) = 0.0 ; enddo do k=1,nz ; do i=is-1,ie+1 - mass(i,j) = mass(i,j) + G%mask2dT(i,j) * (GV%H_to_kg_m2 * h(i,j,k)) + mass(i,j) = mass(i,j) + G%mask2dT(i,j) * (GV%H_to_RZ * h(i,j,k)) enddo ; enddo do i=is-1,ie+1 I_mass(i,j) = 0.0 @@ -279,11 +279,11 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) if (CS%debug) then call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, scale=US%Z_to_m*US%s_to_T) - call hchksum(mass, 'MEKE mass',G%HI,haloshift=1) - call hchksum(drag_rate_visc, 'MEKE drag_rate_visc',G%HI, scale=US%L_T_to_m_s) - call hchksum(bottomFac2, 'MEKE bottomFac2',G%HI) - call hchksum(barotrFac2, 'MEKE barotrFac2',G%HI) - call hchksum(LmixScale, 'MEKE LmixScale',G%HI,scale=US%L_to_m) + call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%R_to_kg_m3*US%Z_to_m) + call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) + call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) + call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) + call hchksum(LmixScale, 'MEKE LmixScale', G%HI,scale=US%L_to_m) endif ! Aggregate sources of MEKE (background, frictional and GM) @@ -295,14 +295,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (associated(MEKE%mom_src)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*US%R_to_kg_m3*US%Z_to_m*MEKE%mom_src(i,j) + src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) enddo ; enddo endif if (associated(MEKE%GME_snk)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_GMECoeff*I_mass(i,j)*US%R_to_kg_m3*US%Z_to_m*MEKE%GME_snk(i,j) + src(i,j) = src(i,j) - CS%MEKE_GMECoeff*I_mass(i,j)*MEKE%GME_snk(i,j) enddo ; enddo endif @@ -310,13 +310,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%GM_src_alt) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_GMcoeff*US%Z_to_m*MEKE%GM_src(i,j) / & + src(i,j) = src(i,j) - CS%MEKE_GMcoeff*MEKE%GM_src(i,j) / & (GV%Rho0 * MAX(1.0*US%m_to_Z, G%bathyT(i,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*US%R_to_kg_m3*US%Z_to_m*MEKE%GM_src(i,j) + src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) enddo ; enddo endif endif @@ -331,7 +331,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculate a viscous drag rate (includes BBL contributions from mean flow and eddies) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_m*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo endif @@ -361,6 +361,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Here the units of MEKE_uflux are [L2 T-2]. MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%mask2dCu(I,j)) * & (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) + ! This would have units of [R Z L2 T-2] ! MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & ! ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & ! (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) @@ -370,6 +371,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Here the units of MEKE_vflux are [L2 T-2]. MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%mask2dCv(i,J)) * & (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) + ! This would have units of [R Z L2 T-2] ! MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * & ! ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & ! (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) @@ -392,7 +394,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h max(G%IareaT(i,j), G%IareaT(i+1,j)))**2 if (K4_here*Inv_K4_max > 0.3) K4_here = 0.3 / Inv_K4_max - ! Here the units of MEKE_uflux are [kg m-2 L4 T-3]. + ! Here the units of MEKE_uflux are [R Z L4 T-3]. MEKE_uflux(I,j) = ((K4_here * (G%dy_Cu(I,j)*G%IdxCu(I,j))) * & ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & (del2MEKE(i+1,j) - del2MEKE(i,j)) @@ -434,7 +436,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max Kh_u(I,j) = Kh_here - ! Here the units of MEKE_uflux and MEKE_vflux are [kg m-2 L4 T-3]. + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3]. MEKE_uflux(I,j) = ((Kh_here * (G%dy_Cu(I,j)*G%IdxCu(I,j))) * & ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & (MEKE%MEKE(i,j) - MEKE%MEKE(i+1,j)) @@ -449,15 +451,15 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max Kh_v(i,J) = Kh_here - ! Here the units of MEKE_uflux and MEKE_vflux are [kg m-2 L4 T-3]. + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3]. MEKE_vflux(i,J) = ((Kh_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & (MEKE%MEKE(i,j) - MEKE%MEKE(i,j+1)) enddo ; enddo if (CS%MEKE_advection_factor>0.) then !### I think that for dimensional consistency, this should be: - ! advFac = GV%H_to_kg_m2 * CS%MEKE_advection_factor / (US%s_to_T*dt) - advFac = GV%H_to_m * CS%MEKE_advection_factor / (US%s_to_T*dt) + ! advFac = GV%H_to_RZ * CS%MEKE_advection_factor / (US%s_to_T*dt) + advFac = US%kg_m3_to_R*GV%H_to_Z * CS%MEKE_advection_factor / (US%s_to_T*dt) !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ! Here the units of the quantities added to MEKE_uflux and MEKE_vflux are [m L4 T-3]. @@ -503,7 +505,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (use_drag_rate) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_m*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo !$OMP parallel do default(shared) @@ -618,7 +620,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: drag_rate_visc !< Mean flow velocity contribution !! to the MEKE drag rate [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: I_mass !< Inverse of column mass [m2 kg-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: I_mass !< Inverse of column mass [R-1 Z-1 ~> m2 kg-1]. ! Local variables real :: beta ! Combined topograpic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] real :: SN ! The local Eady growth rate [T-1 ~> s-1] @@ -636,7 +638,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: FatH ! Coriolis parameter at h points; to compute topographic beta [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] integer :: i, j, is, ie, js, je, n1, n2 - real, parameter :: tolerance = 1.e-12 ! Width of EKE bracket [m2 s-2]. + real :: tolerance ! Width of EKE bracket [L2 T-2 ~> m2 s-2]. logical :: useSecant, debugIteration is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -645,6 +647,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m KhCoeff = CS%MEKE_KhCoeff Ubg2 = CS%MEKE_Uscale**2 cd2 = CS%cdrag**2 + tolerance = 1.0e-12*US%m_s_to_L_T**2 !$OMP do do j=js,je ; do i=is,ie @@ -675,7 +678,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & (G%dF_dy(i,j) + beta_topo_y)**2 ) - I_H = US%L_to_m*US%R_to_kg_m3*GV%Rho0 * I_mass(i,j) + I_H = US%L_to_Z*GV%Rho0 * I_mass(i,j) if (KhCoeff*SN*I_H>0.) then ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E @@ -710,7 +713,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m EKEmax = 10. * EKE ! and guess again for the right bracket if (resid 2.e17) then + if (EKEmax > 2.e17*US%m_s_to_L_T**2) then if (debugIteration) stop 'Something has gone very wrong' debugIteration = .true. resid = 1. ; n1 = 0 @@ -724,7 +727,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! Bisect the bracket n2 = 0 ; EKEerr = EKEmax - EKEmin - do while (US%L_T_to_m_s**2*EKEerr>tolerance) + do while (EKEerr > tolerance) n2 = n2 + 1 if (useSecant) then EKE = EKEmin + (EKEmax - EKEmin) * (ResMin / (ResMin - ResMax)) From 58cb2d45497c7de76f7a3ff7183df63e624cd5ec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Oct 2019 06:59:21 -0400 Subject: [PATCH 118/259] Removed a commented out statement Removed a commented out statement in propagate_int_tide. All answers are bitwise identical. --- src/parameterizations/lateral/MOM_internal_tides.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 09fb07eae1..21e26d1674 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -206,8 +206,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle - I_rho0 = 1.0 / (GV%Rho0) -! dt_in_T = US%s_to_T*dt + I_rho0 = 1.0 / GV%Rho0 cn_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** From 36fef345086b7a43abcf128bd766a27e6798aed6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Oct 2019 07:09:04 -0400 Subject: [PATCH 119/259] Rescaled density units in initialize_temp_salt_fit Rescaled density units in initialize_temp_salt_fit for dimensional consistency testing. All answers are bitwise identical. --- .../MOM_state_initialization.F90 | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index b0a81a53e8..edd29d426e 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1552,9 +1552,9 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P real :: T_Ref ! Reference Temperature [degC] real :: S_Ref ! Reference Salinity [ppt] real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [kg m-3]. + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "initialize_temp_salt_fit" ! This subroutine's name. @@ -1583,32 +1583,32 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T_Ref enddo - call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state) + call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state, scale=US%kg_m3_to_R) if (fit_salin) then ! A first guess of the layers' temperatures. do k=nz,1,-1 - S0(k) = max(0.0, S0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dS(1)) + S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS(1)) enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) do k=1,nz - S0(k) = max(0.0, S0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) + S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) enddo enddo else ! A first guess of the layers' temperatures. do k=nz,1,-1 - T0(k) = T0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dT(1) + T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) enddo do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) do k=1,nz - T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo endif From f03495fb65280dbed9a8eb9c89436298c53af54c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Oct 2019 07:42:07 -0400 Subject: [PATCH 120/259] +Rescaled density units in MOM_T_S_init_from_Z Rescaled density units in MOM_temp_salt_initialize_from_Z for dimensional consistency testing, and added a new optional argument, eps_rho, to find_interfaces. All answers are bitwise identical, but there is a new optional argument to a public interface. --- src/initialization/MOM_state_initialization.F90 | 17 +++++++++++------ src/initialization/midas_vertmap.F90 | 17 +++++++++-------- 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index edd29d426e..961f965bde 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1969,6 +1969,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param integer :: kd, inconsistent integer :: nkd ! number of levels to use for regridding input arrays real :: eps_Z ! A negligibly thin layer thickness [Z ~> m]. + real :: eps_rho ! A negligibly small density difference [R ~> kg m-3]. real :: PI_180 ! for conversion from degrees to radians real, dimension(:,:), pointer :: shelf_area => NULL() @@ -1988,9 +1989,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param logical :: debug = .false. ! manually set this to true for verbose output ! data arrays - real, dimension(:), allocatable :: z_edges_in, z_in, Rb + real, dimension(:), allocatable :: z_edges_in, z_in + real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z - real, dimension(:,:,:), allocatable :: rho_z + real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: nlevs real, dimension(SZI_(G)) :: press ! Pressures [Pa]. @@ -2115,6 +2117,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param !### Change this to GV%Angstrom_Z eps_z = 1.0e-10*US%m_to_Z + eps_rho = 1.0e-10*US%kg_m3_to_R ! Read input grid coordinates for temperature and salinity field ! in z-coordinate dataset. The file is REQUIRED to contain the @@ -2154,7 +2157,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call convert_temp_salt_for_TEOS10(temp_z, salt_z, press, G, kd, mask_z, eos) do k=1,kd ; do j=js,je - call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), is, ie, eos) + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), is, ie, & + eos, scale=US%kg_m3_to_R) enddo ; enddo call pass_var(temp_z,G%Domain) @@ -2286,11 +2290,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! Rb contains the layer interface densities allocate(Rb(nz+1)) - do k=2,nz ; Rb(k) = 0.5*US%R_to_kg_m3*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo - Rb(1) = 0.0 ; Rb(nz+1) = US%R_to_kg_m3*( 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) ) + do k=2,nz ; Rb(k) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo + Rb(1) = 0.0 ; Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) zi(is:ie,js:je,:) = find_interfaces(rho_z(is:ie,js:je,:), z_in, Rb, G%bathyT(is:ie,js:je), & - nlevs(is:ie,js:je), nkml, nkbl, min_depth, eps_z=eps_z) + nlevs(is:ie,js:je), nkml, nkbl, min_depth, eps_z=eps_z, & + eps_rho=eps_rho) if (correct_thickness) then call adjustEtaToFitBathymetry(G, GV, US, zi, h) diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index 9869877b68..f33d476cf0 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -559,12 +559,12 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope !> Find interface positions corresponding to density profile -function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps_z) result(zi) +function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps_z, eps_rho) result(zi) real, dimension(:,:,:), & - intent(in) :: rho !< potential density in z-space [R ~> kg m-3] + intent(in) :: rho !< potential density in z-space [kg m-3 or R ~> kg m-3] real, dimension(size(rho,3)), & - intent(in) :: zin !< Input data levels [Z ~> m or m]. - real, dimension(:), intent(in) :: Rb !< target interface densities [R ~> kg m-3] + intent(in) :: zin !< Input data levels [m or Z ~> m]. + real, dimension(:), intent(in) :: Rb !< target interface densities [kg m-3 or R ~> kg m-3] real, dimension(size(rho,1),size(rho,2)), & intent(in) :: depth !< ocean depth [Z ~> m]. real, dimension(size(rho,1),size(rho,2)), & @@ -573,7 +573,8 @@ function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps integer, optional, intent(in) :: nkml !< number of mixed layer pieces integer, optional, intent(in) :: nkbl !< number of buffer layer pieces real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. - real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m or m]. + real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [m or Z ~> m]. + real, optional, intent(in) :: eps_rho !< A negligibly small density difference [kg m-3 or R ~> kg m-3]. real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi !< The returned interface, in the same units az zin. ! Local variables @@ -589,8 +590,8 @@ function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps integer :: n,i,j,k,l,nx,ny,nz,nt integer :: nlay,kk,nkml_,nkbl_ logical :: debug_ = .false. - real :: epsln_Z ! A negligibly thin layer thickness [Z ~> m]. - real :: epsln_rho ! A negligibly small density change [kg m-3]. + real :: epsln_Z ! A negligibly thin layer thickness [m or Z ~> m]. + real :: epsln_rho ! A negligibly small density change [kg m-3 or R ~> kg m-3]. real, parameter :: zoff=0.999 nlay=size(Rb)-1 @@ -606,7 +607,7 @@ function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps nkbl_ = 0 ; if (PRESENT(nkbl)) nkbl_ = max(0, nkbl) hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml epsln_Z = 1.0e-10 ; if (PRESENT(eps_z)) epsln_Z = eps_z - epsln_rho = 1.0e-10 + epsln_rho = 1.0e-10 ; if (PRESENT(eps_rho)) epsln_rho = eps_rho if (PRESENT(nlevs)) then nlevs_data(:,:) = nlevs(:,:) From 235d3b69db9f6e692b2cc5cb2d574e1a030892d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Oct 2019 09:25:09 -0400 Subject: [PATCH 121/259] Rescaled density units in calc_isoneutral_slopes Rescaled density units in calc_isoneutral_slopes for dimensional consistency testing. All answers are bitwise identical. --- src/core/MOM_isopycnal_slopes.F90 | 38 +++++++++++++++---------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index ae06413e90..282898975e 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -42,7 +42,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !! interfaces between u-points [T-2 ~> s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at - !! interfaces between u-points [[T-2 ~> s-2] + !! interfaces between u-points [T-2 ~> s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute ! real, optional, intent(in) :: eta_to_m !< The conversion factor from the units @@ -51,17 +51,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & T, & ! The temperature [degC], with the values in ! in massless layers filled vertically by diffusion. - S, & ! The filled salinity [ppt], with the values in + S !, & ! The filled salinity [ppt], with the values in ! in massless layers filled vertically by diffusion. - Rho ! Density itself, when a nonlinear equation of state is not in use [kg m-3]. +! Rho ! Density itself, when a nonlinear equation of state is not in use [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & pres ! The pressure at an interface [Pa]. real, dimension(SZIB_(G)) :: & - drho_dT_u, & ! The derivative of density with temperature at u points [kg m-3 degC-1]. - drho_dS_u ! The derivative of density with salinity at u points [kg m-3 ppt-1]. + drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1]. + drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)) :: & - drho_dT_v, & ! The derivative of density with temperature at v points [kg m-3 degC-1]. - drho_dS_v ! The derivative of density with salinity at v points [kg m-3 ppt-1]. + drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1]. + drho_dS_v ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [degC]. S_u, & ! Salinity on the interface at the u-point [ppt]. @@ -71,19 +71,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_v, & ! Salinity on the interface at the v-point [ppt]. pres_v ! Pressure on the interface at the v-point [Pa]. real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density - real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the - ! interface times the grid spacing [kg m-3]. - real :: drdkL, drdkR ! Vertical density differences across an interface [kg m-3]. + real :: drdjA, drdjB ! gradients in the layers above (A) and below (B) the + ! interface times the grid spacing [R ~> kg m-3]. + real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. real :: hg2A, hg2B ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. real :: dzaL, dzaR ! Temporary thicknesses in eta units [Z ~> m]. real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. - real :: drdx, drdy ! Zonal and meridional density gradients [kg m-3 L-1 ~> kg m-4]. - real :: drdz ! Vertical density gradient [kg m-3 Z-1 ~> kg m-4]. + real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. + real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: Slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1. - real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [kg2 m-6 L-2 ~> kg2 m-8]. + real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. real :: slope2_Ratio ! The ratio of the slope squared to slope_max squared. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -91,7 +91,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: dz_neglect ! A change in interface heighs that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. - real :: G_Rho0, N2, dzN2, H_x(SZIB_(G)), H_y(SZI_(G)) + real :: G_Rho0 ! The gravitational acceleration divided by density [Z2 T-2 R-1 ~> m5 kg-2 s-2] real :: Z_to_L ! A conversion factor between from units for e to the ! units for lateral distances. real :: L_to_Z ! A conversion factor between from units for lateral distances @@ -121,7 +121,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & present_N2_u = PRESENT(N2_u) present_N2_v = PRESENT(N2_v) - G_Rho0 = (US%L_to_Z*L_to_Z*GV%g_Earth) / (US%R_to_kg_m3*GV%Rho0) + G_Rho0 = (US%L_to_Z*L_to_Z*GV%g_Earth) / GV%Rho0 if (present_N2_u) then do j=js,je ; do I=is-1,ie N2_u(I,j,1) = 0. @@ -166,7 +166,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 - drdkL = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) ; drdkR = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) + drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) endif ! Calculate the zonal isopycnal slope. @@ -177,7 +177,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) + drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do I=is-1,ie @@ -253,7 +253,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 - drdkL = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) ; drdkR = US%R_to_kg_m3*(GV%Rlay(k)-GV%Rlay(k-1)) + drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) endif if (use_EOS) then @@ -263,7 +263,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & - drho_dS_v, is, ie-is+1, tv%eqn_of_state) + drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=is,ie if (use_EOS) then From e4fea0a351f70cd1ab0146581feb7e3e8245b152 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Oct 2019 09:25:32 -0400 Subject: [PATCH 122/259] (*)Simplified convert_thickness with no eqn of state Refactored convert_thickness to use a much simpler expression for non-Boussinesq cases without an equation of state. This could change answers in such cases, but all answers are bitwise identical for the MOM6-examples test cases. --- src/initialization/MOM_state_initialization.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 961f965bde..6a050b47e2 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -993,9 +993,7 @@ subroutine convert_thickness(h, G, GV, US, tv) enddo else do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = (h(i,j,k) * US%R_to_kg_m3*GV%Rlay(k)) * Hm_rho_to_Pa * GV%kg_m2_to_H**2 - ! This is mathematically equivalent to - ! h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) + h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) enddo ; enddo ; enddo endif endif From 277ff1f4ecaa675d5ef0cde8237ded4f4d0b423c Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 1 Oct 2019 13:36:13 -0400 Subject: [PATCH 123/259] Fix -openmp compilation - HOWEVER, Answers for 1 thread runs differ from answers with no openmp threads!!! - Not acceptable --- src/core/MOM_PressureForce_blocked_AFV.F90 | 2 +- src/core/MOM_barotropic.F90 | 4 +-- src/core/MOM_continuity_PPM.F90 | 4 +-- src/diagnostics/MOM_diagnostics.F90 | 4 +-- .../lateral/MOM_hor_visc.F90 | 15 ++++++++-- .../lateral/MOM_mixed_layer_restrat.F90 | 4 +-- .../lateral/MOM_thickness_diffuse.F90 | 30 +++++++++---------- .../vertical/MOM_diabatic_aux.F90 | 6 ++-- .../vertical/MOM_geothermal.F90 | 4 ++- .../vertical/MOM_vert_friction.F90 | 2 +- src/tracer/MOM_tracer_advect.F90 | 2 +- 11 files changed, 45 insertions(+), 32 deletions(-) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 773bcefc1d..073f790fc5 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -327,7 +327,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, ! geopotentials will not now be linear at the sub-grid-scale. Doing this ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. !$OMP parallel do default(none) shared(nz,za,G,GV,dza,intx_dza,h,PFu, & -!$OMP intp_dza,p,dp_neglect,inty_dza,PFv,CS,dM) & +!$OMP intp_dza,p,dp_neglect,inty_dza,PFv,CS,dM,US) & !$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & !$OMP Jeq_bk,ioff_bk,joff_bk,i,j,za_bk,intx_za_bk, & !$OMP inty_za_bk,dp_bk) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7b2f367487..7984fa97ce 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1262,9 +1262,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP find_etaav,jsvf,jevf,isvf,ievf,eta_sum,eta_wtd, & !$OMP ubt_sum,uhbt_sum,PFu_bt_sum,Coru_bt_sum,ubt_wtd,& !$OMP ubt_trans,vbt_sum,vhbt_sum,PFv_bt_sum, & -!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt,dtbt, & +!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt_in_T,dtbt, & !$OMP Rayleigh_u, Rayleigh_v, & -!$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt) & +!$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt,US) & !$OMP private(u_max_cor,v_max_cor,eta_cor_max,Htot) !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 8a8ecf9da5..a2a125eabe 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -300,7 +300,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & call cpu_clock_begin(id_clock_correct) !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_L,h_R,use_visc_rem,visc_rem_u, & -!$OMP uh,dt,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & +!$OMP uh,dt_in_T,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & !$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC) & !$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & !$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W,any_simple_OBC ) & @@ -1099,7 +1099,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O call cpu_clock_begin(id_clock_correct) !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_L,h_R,vh,use_visc_rem, & -!$OMP visc_rem_v,dt,G,GV,CS,local_specified_BC,OBC,vhbt, & +!$OMP visc_rem_v,dt_in_T,US,G,GV,CS,local_specified_BC,OBC,vhbt, & !$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC ) & !$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & !$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8fa106c4e0..7344a5e677 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -623,7 +623,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) if (CS%id_cg1>0) call post_data(CS%id_cg1, CS%cg1, CS%diag) if (CS%id_Rd1>0) then -!$OMP parallel do default(none) shared(is,ie,js,je,G,CS) & +!$OMP parallel do default(none) shared(is,ie,js,je,G,CS,US) & !$OMP private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. @@ -672,7 +672,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_cg_ebt>0) call post_data(CS%id_cg_ebt, CS%cg1, CS%diag) if (CS%id_Rd_ebt>0) then -!$OMP parallel do default(none) shared(is,ie,js,je,G,CS) & +!$OMP parallel do default(none) shared(is,ie,js,je,G,CS,US) & !$OMP private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 82d20c239b..d9afcab581 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -510,13 +510,24 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP h,rescale_Kh,VarMix,h_neglect,h_neglect3, & !$OMP Kh_h,Ah_h,Kh_q,Ah_q,diffu,diffv,apply_OBC,OBC, & !$OMP find_FrictWork,FrictWork,use_MEKE_Ku, & - !$OMP use_MEKE_Au, MEKE, hq, & + !$OMP use_MEKE_Au, MEKE,sh_xx_3d,sh_xy_3d, & + !$OMP GME_coeff_limiter,boundary_mask,FWfrac,backscat_subround,& !$OMP mod_Leith, legacy_bound, div_xx_h, vort_xy_q) & !$OMP private(Del2u, Del2v, sh_xx, str_xx, visc_bound_rem, & + !$OMP dudx,dvdy,DX_dyBu,DY_dxBu, & + !$OMP grad_div_mag_h,grad_div_mag_q, & + !$OMP grad_vort_mag_h_2d,grad_vort_mag_q_2d, & + !$OMP grad_vort_mag_h,grad_vort_mag_q,vert_vort_mag, & + !$OMP inv_PI3,inv_PI5,grad_vel_mag_h, & + !$OMP grad_d2vel_mag_h,diss_rate,max_diss_rate, & + !$OMP FrictWork_diss,FrictWorkMax, & + !$OMP target_diss_rate_GME,GME_coeff, & + !$OMP grad_vel_mag_bt_h,H0_GME,GME_coeff_h, & + !$OMP str_xx_GME,grad_vel_mag_bt_q,GME_coeff_q,str_xy_GME,FrictWork_GME,& !$OMP sh_xy,str_xy,Ah,Kh,AhSm,dvdx,dudy,dDel2udy, & !$OMP dDel2vdx,sh_xx_bt, sh_xy_bt, dvdx_bt, dudy_bt, & !$OMP bhstr_xx, bhstr_xy,FatH,RoScl, hu, hv,h_u,h_v, & - !$OMP vort_xy,vort_xy_dx,vort_xy_dy,Vort_mag,AhLth, & + !$OMP vort_xy,vort_xy_dx,vort_xy_dy,AhLth, & !$OMP div_xx, div_xx_dx, div_xx_dy, local_strain, & !$OMP meke_res_fn,Sh_F_pow, & !$OMP Shear_mag, h2uq, h2vq, hq, Kh_scale, hrat_min) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index ba241ea4b1..62fb3b6732 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -295,7 +295,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in p0(:) = 0.0 !$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & +!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt_in_T,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_LFront, & !$OMP res_upscale, & @@ -628,7 +628,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, p0(:) = 0.0 !$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail, & -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & +!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt_in_T,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP uDml_diag,vDml_diag,nkml) & !$OMP private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 2b4cdfadee..93aca7d0be 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -182,12 +182,12 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif -!$OMP parallel do default(none) shared(is,ie,js,je,KH_u_CFL,dt,G,CS) +!$OMP parallel do default(none) shared(is,ie,js,je,KH_u_CFL,dt_in_T,G,CS) do j=js,je ; do I=is-1,ie KH_u_CFL(I,j) = (0.25*CS%max_Khth_CFL) / & (dt_in_T * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) enddo ; enddo -!$OMP parallel do default(none) shared(is,ie,js,je,KH_v_CFL,dt,G,CS) +!$OMP parallel do default(none) shared(is,ie,js,je,KH_v_CFL,dt_in_T,G,CS) do j=js-1,je ; do I=is,ie KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / & (dt_in_T * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) @@ -198,7 +198,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp ! Set the diffusivities. !$OMP parallel default(none) shared(is,ie,js,je,Khth_Loc_u,CS,use_VarMix,VarMix, & -!$OMP MEKE,Resoln_scaled,KH_u, & +!$OMP MEKE,Resoln_scaled,KH_u,G,use_QG_Leith,use_Visbeck,& !$OMP KH_u_CFL,nz,Khth_Loc,KH_v,KH_v_CFL,int_slope_u, & !$OMP int_slope_v,khth_use_ebt_struct) !$OMP do @@ -207,8 +207,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo if (use_VarMix) then -!$OMP do if (use_Visbeck) then +!$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) + & CS%KHTH_Slope_Cff*VarMix%L2u(I,j) * VarMix%SN_u(I,j) @@ -217,8 +217,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (associated(MEKE)) then ; if (associated(MEKE%Kh)) then -!$OMP do if (CS%MEKE_GEOMETRIC) then +!$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) + G%mask2dCu(I,j) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)) / & @@ -267,16 +267,16 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (use_VarMix) then -!$OMP do if (use_QG_Leith) then +!$OMP do do k=1,nz ; do j=js,je ; do I=is-1,ie KH_u(I,j,k) = VarMix%KH_u_QG(I,j,k) enddo ; enddo ; enddo endif endif -!$OMP do if (CS%use_GME_thickness_diffuse) then +!$OMP do do k=1,nz+1 ; do j=js,je ; do I=is-1,ie CS%KH_u_GME(I,j,k) = KH_u(I,j,k) enddo ; enddo ; enddo @@ -288,16 +288,16 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo if (use_VarMix) then -!$OMP do if (use_Visbeck) then +!$OMP do do J=js-1,je ; do i=is,ie Khth_loc(i,j) = Khth_loc(i,j) + CS%KHTH_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) enddo ; enddo endif endif if (associated(MEKE)) then ; if (associated(MEKE%Kh)) then -!$OMP do if (CS%MEKE_GEOMETRIC) then +!$OMP do do j=js-1,je ; do I=is,ie Khth_loc(I,j) = Khth_loc(I,j) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & @@ -349,24 +349,24 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (use_VarMix) then -!$OMP do if (use_QG_Leith) then +!$OMP do do k=1,nz ; do J=js-1,je ; do i=is,ie KH_v(i,J,k) = VarMix%KH_v_QG(i,J,k) enddo ; enddo ; enddo endif endif -!$OMP do if (CS%use_GME_thickness_diffuse) then +!$OMP do do k=1,nz+1 ; do J=js-1,je ; do i=is,ie CS%KH_v_GME(i,J,k) = KH_v(i,J,k) enddo ; enddo ; enddo endif if (associated(MEKE)) then ; if (associated(MEKE%Kh)) then -!$OMP do if (CS%MEKE_GEOMETRIC) then +!$OMP do do j=js,je ; do I=is,ie !### This will not give bitwise rotational symmetry. Add parentheses. MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & @@ -477,7 +477,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif - !$OMP parallel do default(none) shared(is,ie,js,je,nz,uhtr,uhD,dt,vhtr,CDp,vhD,h,G,GV) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,uhtr,uhD,dt_in_T,vhtr,CDp,vhD,h,G,GV) do k=1,nz do j=js,je ; do I=is-1,ie uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) * dt_in_T @@ -720,7 +720,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, !$OMP int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & !$OMP uhD,h_avail,G_scale,work_u,CS,slope_x,cg1, & !$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor, & -!$OMP present_slope_x,G_rho0) & +!$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -973,7 +973,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, !$OMP int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1, & !$OMP diag_sfn_y, diag_sfn_unlim_y,N2_floor, & -!$OMP present_slope_y,G_rho0) & +!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 96652a9f45..740cf33897 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -350,7 +350,7 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) salt_add_col(:,:) = 0.0 - !$OMP parallel do default(none) private(mc) + !$OMP parallel do default(shared) private(mc) do j=js,je do k=nz,1,-1 ; do i=is,ie if ( (G%mask2dT(i,j) > 0.0) .and. & @@ -595,7 +595,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb) "in call to find_uv_at_h.") !$OMP parallel do default(none) shared(is,ie,js,je,G,GV,mix_vertically,h,h_neglect, & !$OMP eb,u_h,u,v_h,v,nz,ea) & -!$OMP private(s,Idenom,a_w,a_e,a_s,a_n,b_denom_1,b1,d1,c1) +!$OMP private(sum_area,Idenom,a_w,a_e,a_s,a_n,b_denom_1,b1,d1,c1) do j=js,je do i=is,ie sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) @@ -965,7 +965,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,US,optics,fluxes,dt, & !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & - !$OMP minimum_forcing_depth,evap_CFL_limit, & + !$OMP minimum_forcing_depth,evap_CFL_limit,dt_in_T, & !$OMP calculate_buoyancy,netPen,SkinBuoyFlux,GoRho, & !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 6d81955ab9..db14ef930a 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -156,7 +156,9 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) if (compute_T_old) T_old(:,:,:) = 0.0 !$OMP parallel do default(none) shared(is,ie,js,je,G,GV,CS,dt,Irho_cp,nkmb,tv, & -!$OMP p_Ref,h,Angstrom,nz,H_neglect,eb) & +!$OMP p_Ref,h,Angstrom,nz,H_neglect,eb, & +!$OMP compute_h_old,compute_T_old,h_old,T_old, & +!$OMP work_3d,Idt) & !$OMP private(num_start,heat_rem,do_i,h_geo_rem,num_left,& !$OMP isj,iej,Rcv_BL,h_heated,heat_avail,k_tgt, & !$OMP Rcv_tgt,Rcv,dRcv_dT,T2,S2,dRcv_dT_, & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index b282995d3f..70c9533c69 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1399,7 +1399,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS enddo ! j-loop 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) +!$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,dt_in_T,G,CS,h,H_report) 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 ((u(I,j,k) * (dt_in_T * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 7717fcc050..753faa2a56 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -252,7 +252,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP parallel do default(none) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & !$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v) +!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) ! To ensure positive definiteness of the thickness at each iteration, the ! mass fluxes out of each layer are checked each step, and limited to keep From 4d846ab7705d03fb650a4e2b8f24d53431979c6c Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 1 Oct 2019 14:33:27 -0400 Subject: [PATCH 124/259] Fix openmp threads to reproduce non-openmp answers - One varible was set before OMP section and needs to be firstprivate. - We have to check for consistency of answers between openmp and non-openmp builds. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 740cf33897..1431956a89 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -974,9 +974,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP dThickness,dTemp,dSalt,hOld,Ithickness, & !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & - !$OMP drhodt,drhods,pen_sw_bnd_rate,SurfPressure, & + !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & - !$OMP firstprivate(start,npts) + !$OMP firstprivate(start,npts,SurfPressure) do j=js,je ! Work in vertical slices for efficiency From 3f8e704f4f4789931b0247aace5229ddd74dd7b0 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 1 Oct 2019 22:07:42 -0400 Subject: [PATCH 125/259] OpenMP fix in MOM_hor_visc, and enabled testing This patch fixes some issues with diagnostics in the horizontal viscosity when OpenMP is enabled. It also adds an OpenMP build to the tests, along with OpenMP runtime comparison tests. --- .testing/Makefile | 6 ++- .../lateral/MOM_hor_visc.F90 | 53 ++++++++++--------- 2 files changed, 33 insertions(+), 26 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 8bad469a23..0cd5454e3d 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -36,7 +36,7 @@ MKMF_TEMPLATE ?= $(DEPS)/mkmf/templates/ncrc-gnu.mk # Test configuration # Executables -BUILDS = symmetric asymmetric repro +BUILDS = symmetric asymmetric repro openmp CONFIGS := $(wildcard tc*) TESTS = grids layouts restarts repros nans dims @@ -85,6 +85,7 @@ $(BUILD)/target/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 $(BUILD)/symmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 $(COVFLAG) $(BUILD)/asymmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 $(BUILD)/repro/MOM6: MOMFLAGS=NETCDF=3 REPRO=1 +$(BUILD)/openmp/MOM6: MOMFLAGS=NETCDF=3 OPENMP=1 $(BUILD)/asymmetric/path_names: GRID_SRC=config_src/dynamic $(BUILD)/%/path_names: GRID_SRC=config_src/dynamic_symmetric @@ -170,6 +171,7 @@ test.grids: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(c).grid $(c).grid.diag) test.layouts: $(foreach c,$(CONFIGS),$(c).layout $(c).layout.diag) test.restarts: $(foreach c,$(CONFIGS),$(c).restart) test.repros: $(foreach c,$(CONFIGS),$(c).repro $(c).repro.diag) +test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) test.dims: $(foreach c,$(CONFIGS),$(foreach d,t l h z,$(c).dim.$(d) $(c).dim.$(d).diag)) @@ -188,6 +190,7 @@ $(eval $(call CMP_RULE,regression,symmetric target)) $(eval $(call CMP_RULE,grid,symmetric asymmetric)) $(eval $(call CMP_RULE,layout,symmetric layout)) $(eval $(call CMP_RULE,repro,symmetric repro)) +$(eval $(call CMP_RULE,openmp,symmetric openmp)) $(eval $(call CMP_RULE,nan,symmetric nan)) $(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) @@ -243,6 +246,7 @@ $(eval $(call STAT_RULE,symmetric,symmetric,$(REPORT_COVERAGE),,,1)) $(eval $(call STAT_RULE,asymmetric,asymmetric,,,,1)) $(eval $(call STAT_RULE,target,target,,,,1)) $(eval $(call STAT_RULE,repro,repro,,,,1)) +$(eval $(call STAT_RULE,openmp,openmp,,,,1)) $(eval $(call STAT_RULE,layout,symmetric,,LAYOUT=2$(,)1,,2)) $(eval $(call STAT_RULE,nan,symmetric,,,MALLOC_PERTURB_=256,1)) $(eval $(call STAT_RULE,dim.t,symmetric,,T_RESCALE_POWER=11,,1)) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index d9afcab581..d151a87907 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -506,31 +506,34 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! use_GME - !$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,CS,G,GV,US,u,v,is,js,ie,je, & - !$OMP h,rescale_Kh,VarMix,h_neglect,h_neglect3, & - !$OMP Kh_h,Ah_h,Kh_q,Ah_q,diffu,diffv,apply_OBC,OBC, & - !$OMP find_FrictWork,FrictWork,use_MEKE_Ku, & - !$OMP use_MEKE_Au, MEKE,sh_xx_3d,sh_xy_3d, & - !$OMP GME_coeff_limiter,boundary_mask,FWfrac,backscat_subround,& - !$OMP mod_Leith, legacy_bound, div_xx_h, vort_xy_q) & - !$OMP private(Del2u, Del2v, sh_xx, str_xx, visc_bound_rem, & - !$OMP dudx,dvdy,DX_dyBu,DY_dxBu, & - !$OMP grad_div_mag_h,grad_div_mag_q, & - !$OMP grad_vort_mag_h_2d,grad_vort_mag_q_2d, & - !$OMP grad_vort_mag_h,grad_vort_mag_q,vert_vort_mag, & - !$OMP inv_PI3,inv_PI5,grad_vel_mag_h, & - !$OMP grad_d2vel_mag_h,diss_rate,max_diss_rate, & - !$OMP FrictWork_diss,FrictWorkMax, & - !$OMP target_diss_rate_GME,GME_coeff, & - !$OMP grad_vel_mag_bt_h,H0_GME,GME_coeff_h, & - !$OMP str_xx_GME,grad_vel_mag_bt_q,GME_coeff_q,str_xy_GME,FrictWork_GME,& - !$OMP sh_xy,str_xy,Ah,Kh,AhSm,dvdx,dudy,dDel2udy, & - !$OMP dDel2vdx,sh_xx_bt, sh_xy_bt, dvdx_bt, dudy_bt, & - !$OMP bhstr_xx, bhstr_xy,FatH,RoScl, hu, hv,h_u,h_v, & - !$OMP vort_xy,vort_xy_dx,vort_xy_dy,AhLth, & - !$OMP div_xx, div_xx_dx, div_xx_dy, local_strain, & - !$OMP meke_res_fn,Sh_F_pow, & - !$OMP Shear_mag, h2uq, h2vq, hq, Kh_scale, hrat_min) + !$OMP parallel do default(none) & + !$OMP shared( & + !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & + !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & + !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & + !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask, GME_coeff_limiter, & + !$OMP backscat_subround, & + !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI5, H0_GME, & + !$OMP diffu, diffv, diss_rate, max_diss_rate, target_diss_rate_GME, & + !$OMP Kh_h, Kh_q, Ah_h, Ah_q, & + !$OMP FrictWork, FrictWork_diss, FrictWorkMax, FrictWork_GME, & + !$OMP div_xx_h, sh_xx_3d, sh_xy_3d, vort_xy_q, & + !$OMP GME_coeff_h, GME_coeff_q & + !$OMP ) & + !$OMP private( & + !$OMP i, j, k, n, & + !$OMP dudx, dudy, dvdx, dvdy, sh_xx, sh_xy, h_u, h_v, & + !$OMP Del2u, Del2v, DY_dxBu, DX_dyBu, sh_xx_bt, sh_xy_bt, & + !$OMP str_xx, str_xy, bhstr_xx, bhstr_xy, str_xx_GME, str_xy_GME, & + !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, & + !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, & + !$OMP grad_vort_mag_h_2d, grad_vort_mag_q_2d, grad_vel_mag_h, & + !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & + !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & + !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & + !$OMP dDel2vdx, dDel2udy, & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & + !$OMP ) do k=1,nz ! The following are the forms of the horizontal tension and horizontal From 34f2c395e5ada790fab52e1dd1b93372c54d7b06 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 09:13:42 -0400 Subject: [PATCH 126/259] Rescaled density units in find_eta Rescaled density units in find_eta_3d and find_eta_2d for dimensional consistency testing. All answers are bitwise identical. --- src/core/MOM_interface_heights.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 538e354133..6db05423da 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -66,7 +66,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m H_to_eta = GV%H_to_Z * Z_to_eta - H_to_rho_eta = GV%H_to_kg_m2 * (US%m_to_Z * Z_to_eta) + H_to_rho_eta = GV%H_to_RZ * Z_to_eta I_gEarth = Z_to_eta / (US%Z_to_m * GV%mks_g_Earth) !$OMP parallel default(shared) private(dilate,htot) @@ -116,7 +116,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) else !$OMP do do j=jsv,jev ; do k=nz,1,-1; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + H_to_rho_eta*h(i,j,k) / (US%R_to_kg_m3*GV%Rlay(k)) + eta(i,j,K) = eta(i,j,K+1) + H_to_rho_eta*h(i,j,k) / GV%Rlay(k) enddo ; enddo ; enddo endif if (present(eta_bt)) then @@ -173,7 +173,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m H_to_eta = GV%H_to_Z * Z_to_eta - H_to_rho_eta = GV%H_to_kg_m2 * (US%m_to_Z * Z_to_eta) + H_to_rho_eta = GV%H_to_RZ * Z_to_eta I_gEarth = Z_to_eta / (US%Z_to_m * GV%mks_g_Earth) !$OMP parallel default(shared) private(htot) @@ -214,7 +214,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) else !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + H_to_rho_eta*h(i,j,k) / (US%R_to_kg_m3*GV%Rlay(k)) + eta(i,j) = eta(i,j) + H_to_rho_eta*h(i,j,k) / GV%Rlay(k) enddo ; enddo ; enddo endif if (present(eta_bt)) then From 7a65682373dc23e486abc50b12275a60b14415de Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 09:14:42 -0400 Subject: [PATCH 127/259] +Rescaled density units in MOM_PressureForce_Mont Rescaled density units in MOM_PressureForce_Montgomery for dimensional consistency testing, including changing the units of the alpha_star argument to Set_pbce_nonBous. All answers are bitwise identical. --- src/core/MOM_PressureForce_Montgomery.F90 | 111 +++++++++++----------- 1 file changed, 57 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index e627cba724..5737999426 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -77,13 +77,13 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: pbce !< The baroclinic pressure anomaly in !! each layer due to free surface height anomalies, - !! [m2 s-2 H-1 ~> m s-2 or m4 kg-1 s-2]. + !! [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> kg m-1]. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & M, & ! The Montgomery potential, M = (p/rho + gz) [L2 T-2 ~> m2 s-2]. - alpha_star, & ! Compression adjusted specific volume [m3 kg-1]. + alpha_star, & ! Compression adjusted specific volume [R-1 ~> m3 kg-1]. dz_geo ! The change in geopotential across a layer [m2 s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. ! p may be adjusted (with a nonlinear equation of state) so that @@ -96,7 +96,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! than the mixed layer have the mixed layer's properties [ppt]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the - ! deepest variable density near-surface layer [kg m-3]. + ! deepest variable density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & dM, & ! A barotropic correction to the Montgomery potentials to @@ -110,7 +110,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [Pa] (usually 2e7 Pa = 2000 dbar). - real :: rho_in_situ(SZI_(G)) !In-situ density of a layer [kg m-3]. + real :: rho_in_situ(SZI_(G)) !In-situ density of a layer [R ~> kg m-3]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] real :: dp_neglect ! A thickness that is so small it is usually lost @@ -125,10 +125,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real :: I_gEarth ! The inverse of g_Earth [s2 Z m-2 ~> s2 m-1] ! real :: dalpha - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). - real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [kg m-3]. + real :: Pa_to_p_dyn ! A conversion factor from Pa (= kg m-1 s-2) to the units of + ! dynamic pressure (R L2 T-2) [ R L2 T-2 m s2 kg-1 ~> nondim] + real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). + real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each - ! interface [kg m-3]. + ! interface [R-1 ~> m3 kg-1]. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -148,9 +150,10 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") endif + Pa_to_p_dyn = US%kg_m3_to_R * US%m_s_to_L_T**2 I_gEarth = 1.0 / (US%L_T_to_m_s**2 * GV%g_Earth) dp_neglect = GV%H_to_Pa * GV%H_subroundoff - do k=1,nz ; alpha_Lay(k) = 1.0 / (US%R_to_kg_m3*GV%Rlay(k)) ; enddo + do k=1,nz ; alpha_Lay(k) = 1.0 / (GV%Rlay(k)) ; enddo do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo if (use_p_atm) then @@ -200,7 +203,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 - SSH(i,j) = SSH(i,j) + (US%m_to_Z*GV%H_to_kg_m2)*h(i,j,k)*alpha_Lay(k) + SSH(i,j) = SSH(i,j) + GV%H_to_RZ * h(i,j,k) * alpha_Lay(k) enddo ; enddo ; enddo endif @@ -233,9 +236,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) enddo ; enddo call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & - Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then + if (GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -250,7 +253,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) private(rho_in_situ) do k=1,nz ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k),tv_tmp%S(:,j,k),p_ref, & - rho_in_situ,Isq,Ieq-Isq+2,tv%eqn_of_state) + rho_in_situ,Isq,Ieq-Isq+2,tv%eqn_of_state, scale=US%kg_m3_to_R) do i=Isq,Ieq+1 ; alpha_star(i,j,k) = 1.0 / rho_in_situ(i) ; enddo enddo ; enddo endif ! use_EOS @@ -259,20 +262,20 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - M(i,j,nz) = geopot_bot(i,j) + US%m_s_to_L_T**2*p(i,j,nz+1) * alpha_star(i,j,nz) + M(i,j,nz) = geopot_bot(i,j) + Pa_to_p_dyn*p(i,j,nz+1) * alpha_star(i,j,nz) enddo do k=nz-1,1,-1 ; do i=Isq,Ieq+1 - M(i,j,k) = M(i,j,k+1) + US%m_s_to_L_T**2*p(i,j,K+1) * (alpha_star(i,j,k) - alpha_star(i,j,k+1)) + M(i,j,k) = M(i,j,k+1) + Pa_to_p_dyn*p(i,j,K+1) * (alpha_star(i,j,k) - alpha_star(i,j,k+1)) enddo ; enddo enddo else ! not use_EOS !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - M(i,j,nz) = geopot_bot(i,j) + US%m_s_to_L_T**2*p(i,j,nz+1) * alpha_Lay(nz) + M(i,j,nz) = geopot_bot(i,j) + Pa_to_p_dyn*p(i,j,nz+1) * alpha_Lay(nz) enddo do k=nz-1,1,-1 ; do i=Isq,Ieq+1 - M(i,j,k) = M(i,j,k+1) + US%m_s_to_L_T**2*p(i,j,K+1) * dalpha_int(K+1) + M(i,j,k) = M(i,j,k+1) + Pa_to_p_dyn*p(i,j,K+1) * dalpha_int(K+1) enddo ; enddo enddo endif ! use_EOS @@ -295,11 +298,11 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! enddo ; enddo ! if (use_EOS) then ! do k=2,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 -! M(i,j,k) = M(i,j,k-1) - US%m_s_to_L_T**2*p(i,j,K) * (alpha_star(i,j,k-1) - alpha_star(i,j,k)) +! M(i,j,k) = M(i,j,k-1) - Pa_to_p_dyn*p(i,j,K) * (alpha_star(i,j,k-1) - alpha_star(i,j,k)) ! enddo ; enddo ; enddo ! else ! not use_EOS ! do k=2,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 -! M(i,j,k) = M(i,j,k-1) - US%m_s_to_L_T**2*p(i,j,K) * dalpha_int(K) +! M(i,j,k) = M(i,j,k-1) - Pa_to_p_dyn*p(i,j,K) * dalpha_int(K) ! enddo ; enddo ; enddo ! endif ! use_EOS @@ -320,14 +323,14 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb enddo ; enddo do j=js,je ; do I=Isq,Ieq ! PFu_bc = p* grad alpha* - PFu_bc = US%m_s_to_L_T**2*(alpha_star(i+1,j,k) - alpha_star(i,j,k)) * (G%IdxCu(I,j) * & + PFu_bc = (alpha_star(i+1,j,k) - alpha_star(i,j,k)) * (G%IdxCu(I,j) * Pa_to_p_dyn * & ((dp_star(i,j) * dp_star(i+1,j) + (p(i,j,K) * dp_star(i+1,j) + & p(i+1,j,K) * dp_star(i,j))) / (dp_star(i,j) + dp_star(i+1,j)))) PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc if (associated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - PFv_bc = US%m_s_to_L_T**2*(alpha_star(i,j+1,k) - alpha_star(i,j,k)) * (G%IdyCv(i,J) * & + PFv_bc = (alpha_star(i,j+1,k) - alpha_star(i,j,k)) * (G%IdyCv(i,J) * Pa_to_p_dyn * & ((dp_star(i,j) * dp_star(i,j+1) + (p(i,j,K) * dp_star(i,j+1) + & p(i,j+1,K) * dp_star(i,j))) / (dp_star(i,j) + dp_star(i,j+1)))) PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc @@ -374,7 +377,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !! atmosphere-ocean [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in !! each layer due to free surface height anomalies - !! [m2 s-2 H-1 ~> m s-2]. + !! [L2 T-2 H-1 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> m]. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & @@ -392,7 +395,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! than the mixed layer have the mixed layer's properties [ppt]. real :: Rho_cv_BL(SZI_(G)) ! The coordinate potential density in - ! the deepest variable density near-surface layer [kg m-3]. + ! the deepest variable density near-surface layer [R ~> kg m-3]. real :: h_star(SZI_(G),SZJ_(G)) ! Layer thickness after compensation ! for compressibility [Z ~> m]. real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal @@ -401,7 +404,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [Pa] (usually 2e7 Pa = 2000 dbar). real :: I_Rho0 ! 1/Rho0 [m3 kg-1]. - real :: G_Rho0 ! G_Earth / Rho0 [L2 m3 Z-1 T-2 kg-1 ~> m4 s-2 kg-1]. + real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] real :: h_neglect ! A thickness that is so small it is usually lost @@ -435,7 +438,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, h_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0/CS%Rho0 - G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + G_Rho0 = GV%g_Earth / GV%Rho0 if (CS%tides) then ! Determine the surface height anomaly for calculating self attraction @@ -488,10 +491,10 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) enddo ; enddo call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & - Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then + if (GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -509,8 +512,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !$OMP parallel do default(shared) do k=1,nz+1 ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & - Isq,Ieq-Isq+2,tv%eqn_of_state) - do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R*G_Rho0) enddo ; enddo endif ! use_EOS @@ -616,7 +618,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due !! to free surface height anomalies - !! [m2 H-1 s-2 ~> m4 kg-2 s-2]. + !! [L2 T-2 H-1 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: rho_star !< The layer densities (maybe compressibility !! compensated), times g/rho_0 [L2 Z-1 T-2 ~> m s-2]. @@ -626,9 +628,9 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) real :: press(SZI_(G)) ! Interface pressure [Pa]. real :: T_int(SZI_(G)) ! Interface temperature [degC]. real :: S_int(SZI_(G)) ! Interface salinity [ppt]. - real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [kg m-3 degC-1]. - real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [kg m-3 ppt-1]. - real :: rho_in_situ(SZI_(G)) !In-situ density at the top of a layer [kg m-3]. + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_in_situ(SZI_(G)) ! In-situ density at the top of a layer [R ~> kg m-3]. real :: G_Rho0 ! A scaled version of g_Earth / Rho0 [L2 m3 Z-1 T-2 kg-1 ~> m4 s-2 kg-1] real :: Rho0xG ! g_Earth * Rho0 [kg s-2 m-1 Z-1 ~> kg s-2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using @@ -640,7 +642,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke Rho0xG = Rho0*US%L_T_to_m_s**2 * GV%g_Earth - G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + G_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) z_neglect = GV%H_subroundoff*GV%H_to_Z @@ -665,7 +667,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) press(i) = -Rho0xG*e(i,j,1) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & - Isq, Ieq-Isq+2, tv%eqn_of_state) + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -676,7 +678,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, & - Isq, Ieq-Isq+2, tv%eqn_of_state) + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -717,21 +719,21 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) !! to free surface height anomalies !! [L2 H-1 T-2 ~> m4 kg-1 s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: alpha_star !< The layer specific volumes - !! (maybe compressibility compensated) [m3 kg-1]. + !! (maybe compressibility compensated) [R-1 ~> m3 kg-1]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & dpbce, & ! A barotropic correction to the pbce to enable the use of ! a reduced gravity form of the equations [L2 H-1 T-2 ~> m4 kg-1 s-2]. - C_htot ! dP_dH divided by the total ocean pressure [Z2 s2 m-2 T-2 H-1 ~> m2 kg-1]. + C_htot ! dP_dH divided by the total ocean pressure [R L2 T-2 H-1 Pa-1 ~> m2 kg-1]. real :: T_int(SZI_(G)) ! Interface temperature [degC]. real :: S_int(SZI_(G)) ! Interface salinity [ppt]. - real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [kg m-3 degC-1]. - real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [kg m-3 ppt-1]. - real :: rho_in_situ(SZI_(G)) ! In-situ density at an interface [kg m-3]. - real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [kg m-3]. - real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each interface [kg m-3]. + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_in_situ(SZI_(G)) ! In-situ density at an interface [R ~> kg m-3]. + real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. + real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each interface [R-1 ~> m3 kg-1]. real :: dP_dH ! A factor that converts from thickness to pressure times other dimensional - ! conversion factors [Z2 s2 Pa m-2 T-2 H-1 ~> Pa m2 kg-1]. + ! conversion factors [R L2 T-2 H-1 ~> Pa m2 kg-1]. real :: dp_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [Pa]. logical :: use_EOS ! If true, density is calculated from T & S using @@ -742,12 +744,9 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) use_EOS = associated(tv%eqn_of_state) - dP_dH = US%m_s_to_L_T**2*GV%H_to_Pa + dP_dH = GV%g_Earth * GV%H_to_RZ dp_neglect = GV%H_to_Pa * GV%H_subroundoff - do k=1,nz ; alpha_Lay(k) = 1.0 / (US%R_to_kg_m3*GV%Rlay(k)) ; enddo - do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo - if (use_EOS) then if (present(alpha_star)) then !$OMP parallel do default(shared) @@ -765,10 +764,10 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), & - rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) - pbce(i,j,nz) = dP_dH / rho_in_situ(i) + pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) enddo do k=nz-1,1,-1 do i=Isq,Ieq+1 @@ -776,18 +775,22 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, & - Isq, Ieq-Isq+2, tv%eqn_of_state) + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & - Isq, Ieq-Isq+2, tv%eqn_of_state) + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=Isq,Ieq+1 - pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & + pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & - dR_dS(i)*(tv%S(i,j,k+1)-tv%S(i,j,k))) / rho_in_situ(i)**2) + dR_dS(i)*(tv%S(i,j,k+1)-tv%S(i,j,k))) / (rho_in_situ(i)**2)) enddo enddo enddo endif else ! not use_EOS + + do k=1,nz ; alpha_Lay(k) = 1.0 / (GV%Rlay(k)) ; enddo + do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 @@ -796,7 +799,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) enddo do k=nz-1,1,-1 ; do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & - dalpha_int(K+1) + dalpha_int(K+1) enddo ; enddo enddo endif ! use_EOS From fa02d85a7a9b01fed1ebd0f19f57a55cde8b9858 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 09:15:02 -0400 Subject: [PATCH 128/259] Rescaled density units in MOM_PressureForce_AFV Partially rescaled density units in MOM_PressureForce_analytic_FV and MOM_PressureForce_blocked_AFV for dimensional consistency testing. Because of the close interactions with the equation of state routines, some density-related variables and pressures could not be conveniently rescaled, so the rescaling is only partial and some unit conversion factors persist. All answers are bitwise identical. --- src/core/MOM_PressureForce_analytic_FV.F90 | 63 ++++++++++++---------- src/core/MOM_PressureForce_blocked_AFV.F90 | 61 +++++++++++---------- 2 files changed, 67 insertions(+), 57 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 3e1e2f72e1..75a2dfad7f 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -145,7 +145,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! interface atop a layer [m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer [kg m-3]. + ! density near-surface layer [R ~> kg m-3]. real, dimension(SZIB_(G),SZJ_(G)) :: & intx_za ! The zonal integral of the geopotential anomaly along the ! interface below a layer, divided by the grid spacing [m2 s-2]. @@ -229,9 +229,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) enddo ; enddo call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & - Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then + if (GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -469,9 +469,10 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: & Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer [kg m-3]. + ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dz, & ! The change in geopotential thickness through a layer [m2 s-2]. + dz_geo, & ! The change in geopotential thickness through a layer times some dimensional + ! rescaling factors [kg m-1 R-1 s-2 ~> m2 s-2]. pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the ! the interface atop a layer [Pa]. dpa, & ! The change in pressure anomaly between the top and bottom @@ -495,16 +496,18 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions ! of salinity and temperature within each layer. - real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. + real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [Pa] (usually 2e7 Pa = 2000 dbar). real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m]. - real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: g_Earth_mks_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: g_Earth_z_geo ! Another scaled version of g_Earth [R m5 kg-1 Z-1 s-2 ~> m s-2]. real :: I_Rho0 ! 1/Rho0 times unit scaling factors [L2 m kg-1 s2 T-2 ~> m3 kg-1]. - real :: G_Rho0 ! G_Earth / Rho0 in [L2 m5 Z-1 T-2 kg-1 ~> m4 s-2 kg-1]. - real :: Rho_ref ! The reference density [kg m-3]. + real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: Rho_ref ! The reference density [R ~> kg m-3]. + real :: Rho_ref_mks ! The reference density in mks units [kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. @@ -532,9 +535,11 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) - g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) - rho_ref = CS%Rho0 + g_Earth_mks_z = US%L_T_to_m_s**2 * GV%g_Earth + g_Earth_z_geo = US%R_to_kg_m3*US%L_T_to_m_s**2 * GV%g_Earth + G_Rho0 = GV%g_Earth / GV%Rho0 + rho_ref_mks = CS%Rho0 + rho_ref = rho_ref_mks*US%kg_m3_to_R if (CS%tides) then ! Determine the surface height anomaly for calculating self attraction @@ -587,10 +592,10 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) enddo ; enddo call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & - Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then + if (GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -609,11 +614,11 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at !$OMP parallel do default(shared) do j=Jsq,Jeq+1 if (use_p_atm) then - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), & - rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, & - rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) @@ -622,7 +627,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * US%R_to_kg_m3*GV%Rlay(1)) * e(i,j,1) + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * e(i,j,1) enddo ; enddo endif endif @@ -646,12 +651,12 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*g_Earth_z)*e(i,j,1) + p_atm(i,j) + pa(i,j) = (rho_ref*g_Earth_z_geo)*e(i,j,1) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*g_Earth_z)*e(i,j,1) + pa(i,j) = (rho_ref*g_Earth_z_geo)*e(i,j,1) enddo ; enddo endif !$OMP parallel do default(shared) @@ -677,20 +682,20 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at if ( CS%Recon_Scheme == 1 ) then 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, g_Earth_z, & + rho_ref_mks, CS%Rho0, g_Earth_mks_z, & dz_neglect, G%bathyT, G%HI, G%HI, & tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp = CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, g_Earth_z, & + rho_ref_mks, CS%Rho0, g_Earth_mks_z, & G%HI, G%HI, tv%eqn_of_state, dpa, intz_dpa, & intx_dpa, inty_dpa) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, g_Earth_z, G%HI, G%HI, tv%eqn_of_state, & + rho_ref_mks, CS%Rho0, g_Earth_mks_z, G%HI, G%HI, tv%eqn_of_state, & dpa, intz_dpa, intx_dpa, inty_dpa, & G%bathyT, dz_neglect, CS%useMassWghtInterp) endif @@ -701,17 +706,17 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz(i,j) = g_Earth_z * GV%H_to_Z*h(i,j,k) - dpa(i,j) = (US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz(i,j) - intz_dpa(i,j) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz(i,j)*h(i,j,k) + dz_geo(i,j) = g_Earth_z_geo * GV%H_to_Z*h(i,j,k) + dpa(i,j) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) + intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_dpa(I,j) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i+1,j)) + intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) enddo ; enddo !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_dpa(i,J) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i,j+1)) + inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) enddo ; enddo endif diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 87d8d0fc8f..c5b2985473 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -143,7 +143,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, ! interface atop a layer [m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer [kg m-3]. + ! density near-surface layer [R ~> kg m-3]. real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices intx_za_bk ! The zonal integral of the geopotential anomaly along the ! interface below a layer, divided by the grid spacing [m2 s-2]. @@ -225,9 +225,9 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) enddo ; enddo call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & - Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then + if (GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -450,9 +450,10 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: & Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer [kg m-3]. + ! density near-surface layer [R ~> kg m-3]. real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - dz_bk, & ! The change in geopotential thickness through a layer [m2 s-2]. + dz_bk, & ! The change in geopotential thickness through a layer times some dimensional + ! rescaling factors [kg m-1 R-1 s-2 ~> m2 s-2]. pa_bk, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the ! the interface atop a layer [Pa]. dpa_bk, & ! The change in pressure anomaly between the top and bottom @@ -476,16 +477,18 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & S_t, S_b, & ! Top and bottom edge salinities for linear reconstructions within each layer [ppt]. T_t, T_b ! Top and bottom edge temperatures for linear reconstructions within each layer [degC]. - real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. + real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [Pa] (usually 2e7 Pa = 2000 dbar). real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: I_Rho0 ! 1/Rho0 times unit scaling factors [L2 m kg-1 s2 T-2 ~> m3 kg-1]. - real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: G_Rho0 ! G_Earth / Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. - real :: Rho_ref ! The reference density [kg m-3]. + real :: g_Earth_mks_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: g_Earth_z_geo ! Another scaled version of g_Earth [R m5 kg-1 Z-1 s-2 ~> m s-2]. + real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: Rho_ref ! The reference density [R-1 ~> kg m-3]. + real :: Rho_ref_mks ! The reference density in mks units [kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. @@ -516,9 +519,11 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) - g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - G_Rho0 = GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) - rho_ref = CS%Rho0 + g_Earth_mks_z = US%L_T_to_m_s**2 * GV%g_Earth + g_Earth_z_geo = US%R_to_kg_m3*US%L_T_to_m_s**2 * GV%g_Earth + G_Rho0 = GV%g_Earth / GV%Rho0 + Rho_ref_mks = CS%Rho0 + Rho_ref = Rho_ref_mks*US%kg_m3_to_R if (CS%tides) then ! Determine the surface height anomaly for calculating self attraction @@ -571,10 +576,10 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) enddo ; enddo call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & - Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) do k=nkmb+1,nz ; do i=Isq,Ieq+1 - if (US%R_to_kg_m3*GV%Rlay(k) < Rho_cv_BL(i)) then + if (GV%Rlay(k) < Rho_cv_BL(i)) then tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) else tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -594,10 +599,10 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, do j=Jsq,Jeq+1 if (use_p_atm) then call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), & - rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) else call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, & - rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) @@ -606,7 +611,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * US%R_to_kg_m3*GV%Rlay(1)) * e(i,j,1) + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * e(i,j,1) enddo ; enddo endif endif @@ -624,7 +629,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, endif endif -!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e,p_atm,nz,use_EOS,& +!$OMP parallel do default(none) shared(use_p_atm,Rho_ref,Rho_ref_mks,G,GV,e,p_atm,nz,use_EOS,& !$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp,g_Earth_z, & !$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, & @@ -645,12 +650,12 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, if (use_p_atm) then do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (rho_ref*g_Earth_z)*e(i,j,1) + p_atm(i,j) + pa_bk(ib,jb) = (Rho_ref*g_Earth_z_geo)*e(i,j,1) + p_atm(i,j) enddo ; enddo else do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (rho_ref*g_Earth_z)*e(i,j,1) + pa_bk(ib,jb) = (Rho_ref*g_Earth_z_geo)*e(i,j,1) enddo ; enddo endif do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk @@ -674,20 +679,20 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, if ( CS%Recon_Scheme == 1 ) then 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, g_Earth_z, & + Rho_ref_mks, CS%Rho0, g_Earth_mks_z, & 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 ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, g_Earth_z, & + Rho_ref_mks, CS%Rho0, g_Earth_mks_z, & G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & intx_dpa_bk, inty_dpa_bk) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, g_Earth_z, G%HI, G%Block(n), tv%eqn_of_state, & + Rho_ref_mks, CS%Rho0, g_Earth_mks_z, G%HI, G%Block(n), tv%eqn_of_state, & dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & G%bathyT, dz_neglect, CS%useMassWghtInterp) endif @@ -697,15 +702,15 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, else do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 i = ib+ioff_bk ; j = jb+joff_bk - dz_bk(ib,jb) = g_Earth_z*GV%H_to_Z*h(i,j,k) - dpa_bk(ib,jb) = (US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz_bk(ib,jb) - intz_dpa_bk(ib,jb) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref)*dz_bk(ib,jb)*h(i,j,k) + dz_bk(ib,jb) = g_Earth_z_geo*GV%H_to_Z*h(i,j,k) + dpa_bk(ib,jb) = (GV%Rlay(k) - Rho_ref)*dz_bk(ib,jb) + intz_dpa_bk(ib,jb) = 0.5*(GV%Rlay(k) - Rho_ref) * dz_bk(ib,jb)*h(i,j,k) enddo ; enddo do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - intx_dpa_bk(Ib,jb) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib+1,jb)) + intx_dpa_bk(Ib,jb) = 0.5*(GV%Rlay(k) - Rho_ref) * (dz_bk(ib,jb)+dz_bk(ib+1,jb)) enddo ; enddo do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - inty_dpa_bk(ib,Jb) = 0.5*(US%R_to_kg_m3*GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib,jb+1)) + inty_dpa_bk(ib,Jb) = 0.5*(GV%Rlay(k) - Rho_ref) * (dz_bk(ib,jb)+dz_bk(ib,jb+1)) enddo ; enddo endif From 27a9edda100d38f764afc9194091673b386f5aba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 09:15:50 -0400 Subject: [PATCH 129/259] Rescaled density units in adjust_ssh_for_p_atm Rescaled density units in adjust_ssh_for_p_atm for dimensional consistency testing. All answers are bitwise identical. --- src/core/MOM.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7837f72b3b..fb07d8b78b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2662,7 +2662,7 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) !! the SSH correction using the equation of state. real :: Rho_conv ! The density used to convert surface pressure to - ! a corrected effective SSH [kg m-3]. + ! a corrected effective SSH [R ~> kg m-3]. real :: IgR0 ! The SSH conversion factor from Pa to m [m Pa-1]. logical :: calc_rho integer :: i, j, is, ie, js, je @@ -2676,11 +2676,11 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) do j=js,je ; do i=is,ie 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) + Rho_conv, tv%eqn_of_state, scale=US%kg_m3_to_R) else - Rho_conv = US%R_to_kg_m3*GV%Rho0 + Rho_conv = GV%Rho0 endif - IgR0 = 1.0 / (Rho_conv * GV%mks_g_Earth) + IgR0 = 1.0 / (Rho_conv * US%R_to_kg_m3*GV%mks_g_Earth) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 enddo ; enddo endif ; endif From 594300efe98aaae444b410fe5438782f95705bc2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 11:07:53 -0400 Subject: [PATCH 130/259] Rescaled density units in calc_diagnostic_fields Rescaled density units in some places in calculate_diagnostic_fields for dimensional consistency testing. All solutions are bitwise identical. --- src/diagnostics/MOM_diagnostics.F90 | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 47aeaf547e..ed94728c6c 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -222,7 +222,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! Local variables integer i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - ! coordinate variable potential density [kg m-3]. + ! coordinate variable potential density [R ~> kg m-3]. real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Two temporary work arrays real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) @@ -464,14 +464,14 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (associated(tv%eqn_of_state)) then pressure_1d(:) = tv%P_Ref -!$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d) + !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, & - Rcv(:,j,k), is-1, ie-is+3, tv%eqn_of_state) + Rcv(:,j,k), is-1, ie-is+3, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - Rcv(i,j,k) = US%R_to_kg_m3*GV%Rlay(k) + Rcv(i,j,k) = GV%Rlay(k) enddo ; enddo ; enddo endif if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rcv, CS%diag) @@ -489,7 +489,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%h_Rlay(i,j,k) = h(i,j,k) enddo ; enddo do k=1,nkmb ; do i=is,ie - call find_weights(US%R_to_kg_m3*GV%Rlay, Rcv(i,j,k), k_list, nz, wt, wt_p) + call find_weights(GV%Rlay, Rcv(i,j,k), k_list, nz, wt, wt_p) CS%h_Rlay(i,j,k_list) = CS%h_Rlay(i,j,k_list) + h(i,j,k)*wt CS%h_Rlay(i,j,k_list+1) = CS%h_Rlay(i,j,k_list+1) + h(i,j,k)*wt_p enddo ; enddo @@ -511,7 +511,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ; enddo k_list = nz/2 do k=1,nkmb ; do I=Isq,Ieq - call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) CS%uh_Rlay(I,j,k_list) = CS%uh_Rlay(I,j,k_list) + uh(I,j,k)*wt CS%uh_Rlay(I,j,k_list+1) = CS%uh_Rlay(I,j,k_list+1) + uh(I,j,k)*wt_p enddo ; enddo @@ -532,7 +532,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%vh_Rlay(i,J,k) = vh(i,J,k) enddo ; enddo do k=1,nkmb ; do i=is,ie - call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) CS%vh_Rlay(i,J,k_list) = CS%vh_Rlay(i,J,k_list) + vh(i,J,k)*wt CS%vh_Rlay(i,J,k_list+1) = CS%vh_Rlay(i,J,k_list+1) + vh(i,J,k)*wt_p enddo ; enddo @@ -553,7 +553,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%uhGM_Rlay(I,j,k) = CDp%uhGM(I,j,k) enddo ; enddo do k=1,nkmb ; do I=Isq,Ieq - call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i+1,j,k)), k_list, nz, wt, wt_p) CS%uhGM_Rlay(I,j,k_list) = CS%uhGM_Rlay(I,j,k_list) + CDp%uhGM(I,j,k)*wt CS%uhGM_Rlay(I,j,k_list+1) = CS%uhGM_Rlay(I,j,k_list+1) + CDp%uhGM(I,j,k)*wt_p enddo ; enddo @@ -574,7 +574,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%vhGM_Rlay(i,J,k) = CDp%vhGM(i,J,k) enddo ; enddo do k=1,nkmb ; do i=is,ie - call find_weights(US%R_to_kg_m3*GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) + call find_weights(GV%Rlay, 0.5*(Rcv(i,j,k)+Rcv(i,j+1,k)), k_list, nz, wt, wt_p) CS%vhGM_Rlay(i,J,k_list) = CS%vhGM_Rlay(i,J,k_list) + CDp%vhGM(i,J,k)*wt CS%vhGM_Rlay(i,J,k_list+1) = CS%vhGM_Rlay(i,J,k_list+1) + CDp%vhGM(i,J,k)*wt_p enddo ; enddo @@ -1563,10 +1563,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag if (CS%id_e_D>0) call safe_alloc_ptr(CS%e_D,isd,ied,jsd,jed,nz+1) CS%id_Rml = register_diag_field('ocean_model', 'Rml', diag%axesTL, Time, & - 'Mixed Layer Coordinate Potential Density', 'kg m-3') + 'Mixed Layer Coordinate Potential Density', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_Rcv = register_diag_field('ocean_model', 'Rho_cv', diag%axesTL, Time, & - 'Coordinate Potential Density', 'kg m-3') + 'Coordinate Potential Density', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rhopot0 = register_diag_field('ocean_model', 'rhopot0', diag%axesTL, Time, & 'Potential density referenced to surface', 'kg m-3') From 8efd5aeebfed8203478315a547d55eac61f61ee1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 11:08:15 -0400 Subject: [PATCH 131/259] Rescaled density units in MOM_wave_speed.F90 Rescaled density units in wave_speed and wave_speeds for dimensional consistency testing. All answers are bitwise identical. --- src/diagnostics/MOM_wave_speed.F90 | 80 ++++++++++++++++++++---------- 1 file changed, 53 insertions(+), 27 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index f8ac508a28..d998438b0b 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -71,29 +71,42 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! Local variables real, dimension(SZK_(G)+1) :: & - dRho_dT, dRho_dS, & - pres, T_int, S_int, & + dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + pres, & ! Interface pressure [Pa] + T_int, & ! Temperature interpolated to interfaces [degC] + S_int, & ! Salinity interpolated to interfaces [ppt] gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. + ! The thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. real, dimension(SZK_(G),SZI_(G)) :: & - Hf, Tf, Sf, Rf + Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] + Tf, & ! Layer temperatures after very thin layers are combined [degC] + Sf, & ! Layer salinities after very thin layers are combined [ppt] + Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(G)) :: & - Hc, Tc, Sc, Rc + Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] + Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] + Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] + Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] real det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 real :: lam, dlam, lam0 real :: min_h_frac real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses [Z ~> m]. - H_here, HxT_here, HxS_here, HxR_here - real :: speed2_tot - real :: I_Hnew, drxh_sum + htot, hmin, & ! Thicknesses [Z ~> m] + H_here, & ! A thickness [Z ~> m] + HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] + HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] + HxR_here ! A layer integrated density [R Z ~> kg m-2] + real :: speed2_tot ! overestimate of the mode-1 speed squared [m2 s-2] + real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] + real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 m-2 ~> 1]. real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. real :: rescale, I_rescale integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 @@ -132,7 +145,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 Z_to_Pa = GV%Z_to_H * GV%H_to_Pa use_EOS = associated(tv%eqn_of_state) @@ -192,10 +205,10 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! Start a new layer H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) else H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -214,7 +227,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state) + kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. @@ -528,9 +541,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) !! over the entire computational domain. ! Local variables real, dimension(SZK_(G)+1) :: & - dRho_dT, dRho_dS, & - pres, T_int, S_int, & - gprime ! The reduced gravity across each interface [m s-2] + dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + pres, & ! Interface pressure [Pa] + T_int, & ! Temperature interpolated to interfaces [degC] + S_int, & ! Salinity interpolated to interfaces [ppt] + gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. @@ -539,9 +555,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! diagonals of tridiagonal matrix; one value for each ! interface (excluding surface and bottom) real, dimension(SZK_(G),SZI_(G)) :: & - Hf, Tf, Sf, Rf + Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] + Tf, & ! Layer temperatures after very thin layers are combined [degC] + Sf, & ! Layer salinities after very thin layers are combined [ppt] + Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(G)) :: & - Hc, Tc, Sc, Rc + Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] + Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] + Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] + Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] real, parameter :: c1_thresh = 0.01 ! if c1 is below this value, don't bother calculating ! cn values for higher modes @@ -564,16 +586,20 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) real :: min_h_frac real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses [Z ~> m]. - H_here, HxT_here, HxS_here, HxR_here + htot, hmin, & ! Thicknesses [Z ~> m] + H_here, & ! A thickness [Z ~> m] + HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] + HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] + HxR_here ! A layer integrated density [R Z ~> kg m-2] real :: speed2_tot ! overestimate of the mode-1 speed squared [m2 s-2] real :: speed2_min ! minimum mode speed (squared) to consider in root searching real, parameter :: reduct_factor = 0.5 ! factor used in setting speed2_min - real :: I_Hnew, drxh_sum + real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] + real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. @@ -600,7 +626,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif ; endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) Z_to_Pa = GV%Z_to_H * GV%H_to_Pa @@ -649,10 +675,10 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Start a new layer H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) else H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -672,7 +698,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state) + kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. From d072db245ca4fd0253b15504f935fe654069534b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 11:08:35 -0400 Subject: [PATCH 132/259] Rescaled density units in wave_structure Rescaled density units in wave_structure for dimensional consistency testing. All answers are bitwise identical in the MOM6-examples test cases, although this code may not be well exercised in these tests. --- src/diagnostics/MOM_wave_structure.F90 | 51 ++++++++++++++++---------- 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 80e311de6c..68667df71b 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -107,30 +107,43 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo !! over the entire computational domain. ! Local variables real, dimension(SZK_(G)+1) :: & - dRho_dT, dRho_dS, & - pres, T_int, S_int, & + dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + pres, & ! Interface pressure [Pa] + T_int, & ! Temperature interpolated to interfaces [degC] + S_int, & ! Salinity interpolated to interfaces [ppt] gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. real, dimension(SZK_(G),SZI_(G)) :: & - Hf, Tf, Sf, Rf + Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] + Tf, & ! Layer temperatures after very thin layers are combined [degC] + Sf, & ! Layer salinities after very thin layers are combined [ppt] + Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(G)) :: & - Hc, Tc, Sc, Rc, & + Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] + Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] + Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] + Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] det, ddet real, dimension(SZI_(G),SZJ_(G)) :: & - htot + htot ! The vertical sum of the thicknesses [Z ~> m] real :: lam real :: min_h_frac real :: H_to_pres real, dimension(SZI_(G)) :: & - hmin, & ! Thicknesses [Z ~> m]. - H_here, HxT_here, HxS_here, HxR_here + hmin, & ! Thicknesses [Z ~> m] + H_here, & ! A thickness [Z ~> m] + HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] + HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] + HxR_here ! A layer integrated density [R Z ~> kg m-2] real :: speed2_tot - real :: I_Hnew, drxh_sum + real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] + real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 in [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 in [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. ! real :: rescale, I_rescale integer :: kf(SZI_(G)) integer, parameter :: max_itt = 1 ! number of times to iterate in solving for eigenvector @@ -182,7 +195,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo Pi = (4.0*atan(1.0)) S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 cg_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. use_EOS = associated(tv%eqn_of_state) @@ -233,10 +246,10 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! Start a new layer H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) else H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*US%R_to_kg_m3*GV%Rlay(k) + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -264,15 +277,15 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state) + kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. drxh_sum = 0.0 do k=2,kf(i) drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,drho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & - drho_dS(k)*(Sf(k,i)-Sf(k-1,i))) + max(0.0,dRho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & + dRho_dS(k)*(Sf(k,i)-Sf(k-1,i))) enddo else drxh_sum = 0.0 @@ -291,7 +304,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo kc = 1 Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if ((drho_dT(k)*(Tf(k,i)-Tc(kc)) + drho_dS(k)*(Sf(k,i)-Sc(kc))) * & + if ((dRho_dT(k)*(Tf(k,i)-Tc(kc)) + dRho_dS(k)*(Sf(k,i)-Sc(kc))) * & (Hc(kc) + Hf(k,i)) < 2.0 * tol2*drxh_sum) then ! Merge this layer with the one above and backtrack. I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) @@ -302,7 +315,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if ((drho_dT(k2)*(Tc(k2)-Tc(k2-1)) + drho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & + if ((dRho_dT(k2)*(Tc(k2)-Tc(k2-1)) + dRho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & (Hc(k2) + Hc(k2-1)) < tol2*drxh_sum) then ! Merge the two bottommost layers. At this point kc = k2. I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) @@ -321,8 +334,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo enddo ! At this point there are kc layers and the gprimes should be positive. do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (drho_dT(k)*(Tc(k)-Tc(k-1)) + & - drho_dS(k)*(Sc(k)-Sc(k-1))) + gprime(k) = g_Rho0 * (dRho_dT(k)*(Tc(k)-Tc(k-1)) + & + dRho_dS(k)*(Sc(k)-Sc(k-1))) enddo else ! .not.use_EOS ! Do the same with density directly... From 45de704b2a5ac64ac42302bf81bc7e4ab72dab8d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 14:44:15 -0400 Subject: [PATCH 133/259] Rescaled density units in MOM_tracer_hor_diff.F90 Rescaled density units in tracer_epipycnal_ML_diff for dimensional consistency testing. All answers are bitwise identical. --- src/tracer/MOM_tracer_hor_diff.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index bc3e7255d3..c688c009d3 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -561,9 +561,9 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G), SZJ_(G)) :: & - Rml_max ! The maximum coordinate density within the mixed layer [kg m-3]. + Rml_max ! The maximum coordinate density within the mixed layer [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G), max(1,GV%nk_rho_varies)) :: & - rho_coord ! The coordinate density that is used to mix along [kg m-3]. + rho_coord ! The coordinate density that is used to mix along [R ~> kg m-3]. ! The naming mnemnonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. ! These are 1-D arrays of pointers to 2-d arrays to minimize memory usage. @@ -587,7 +587,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R real, dimension(SZI_(G), SZK_(G), SZJ_(G)) :: & - rho_srt, & ! The density of each layer of the sorted columns [kg m-3]. + rho_srt, & ! The density of each layer of the sorted columns [R ~> kg m-3]. h_srt ! The thickness of each layer of the sorted columns [H ~> m or kg m-2]. integer, dimension(SZI_(G), SZK_(G), SZJ_(G)) :: & k0_srt ! The original k-index that each layer of the sorted column @@ -620,7 +620,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! for inclusion in mixing [H ~> m or kg m-2]. real :: Idt ! The inverse of the time step [s-1]. real :: I_maxitt ! The inverse of the maximum number of iterations. - real :: rho_pair, rho_a, rho_b ! Temporary densities [kg m-3]. + real :: rho_pair, rho_a, rho_b ! Temporary densities [R ~> kg m-3]. real :: Tr_min_face ! The minimum and maximum tracer concentrations real :: Tr_max_face ! associated with a pairing [Conc] real :: Tr_La, Tr_Lb ! The 4 tracer concentrations that might be @@ -665,7 +665,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel do default(shared) do k=1,nkmb ; do j=js-2,je+2 call calculate_density(tv%T(:,j,k),tv%S(:,j,k), p_ref_cv, & - rho_coord(:,j,k), is-2, ie-is+5, tv%eqn_of_state) + rho_coord(:,j,k), is-2, ie-is+5, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo ; enddo do j=js-2,je+2 ; do i=is-2,ie+2 @@ -681,14 +681,14 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel do default(none) shared(is,ie,js,je,nz,nkmb,G,GV,Rml_max,max_kRho) & !$OMP private(k_min,k_max,k_test) do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then - if (Rml_max(i,j) > US%R_to_kg_m3*GV%Rlay(nz)) then ; max_kRho(i,j) = nz+1 - elseif (Rml_max(i,j) <= US%R_to_kg_m3*GV%Rlay(nkmb+1)) then ; max_kRho(i,j) = nkmb+1 + if (Rml_max(i,j) > GV%Rlay(nz)) then ; max_kRho(i,j) = nz+1 + elseif (Rml_max(i,j) <= GV%Rlay(nkmb+1)) then ; max_kRho(i,j) = nkmb+1 else k_min = nkmb+2 ; k_max = nz do k_test = (k_min + k_max) / 2 - if (Rml_max(i,j) <= US%R_to_kg_m3*GV%Rlay(k_test-1)) then ; k_max = k_test-1 - elseif (US%R_to_kg_m3*GV%Rlay(k_test) < Rml_max(i,j)) then ; k_min = k_test+1 + if (Rml_max(i,j) <= GV%Rlay(k_test-1)) then ; k_max = k_test-1 + elseif (GV%Rlay(k_test) < Rml_max(i,j)) then ; k_min = k_test+1 else ; max_kRho(i,j) = k_test ; exit ; endif if (k_min == k_max) then ; max_kRho(i,j) = k_max ; exit ; endif @@ -722,7 +722,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & if ((k<=k_end_srt(i,j)) .and. (h(i,j,k) > h_exclude)) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k - rho_srt(i,ns,j) = US%R_to_kg_m3*GV%Rlay(k) + rho_srt(i,ns,j) = GV%Rlay(k) h_srt(i,ns,j) = h(i,j,k) endif endif ; enddo ; enddo From e13745191bdf41fedb8523b3bfb034c69f3f5f36 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 14:44:43 -0400 Subject: [PATCH 134/259] Rescaled density units in DOME_initialization.F90 Rescaled density units in DOME_set_OBC_data for dimensional consistency testing. All answers are bitwise identical. --- src/user/DOME_initialization.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index fa3a18b411..5bf3efadcb 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -260,9 +260,9 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! The following variables are used to set the target temperature and salinity. real :: T0(SZK_(G)), S0(SZK_(G)) real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [kg m-3]. + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. ! The following variables are used to set up the transport in the DOME example. real :: tr_0, y1, y2, tr_k, rst, rsb, rc, v_k, lon_im1 real :: D_edge ! The thickness [Z ~> m], of the dense fluid at the @@ -290,7 +290,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) if (.not.associated(OBC)) return - g_prime_tot = (GV%g_Earth / (US%R_to_kg_m3*GV%Rho0))*2.0 + g_prime_tot = (GV%g_Earth / GV%Rho0) * 2.0*US%kg_m3_to_R Def_Rad = US%L_to_m*sqrt(D_edge*g_prime_tot) / (1.0e-4*US%T_to_s * 1000.0) tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*US%m_to_L*Def_Rad) * GV%Z_to_H @@ -345,14 +345,14 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! target density and a salinity of 35 psu. This code is taken from ! USER_initialize_temp_sal. pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 - call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),tv%eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,tv%eqn_of_state) + call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,tv%eqn_of_state, scale=US%kg_m3_to_R) - do k=1,nz ; T0(k) = T0(1) + (US%R_to_kg_m3*GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo + do k=1,nz ; T0(k) = T0(1) + (GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,tv%eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,tv%eqn_of_state) - do k=1,nz ; T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo + call calculate_density(T0,S0,pres,rho_guess,1,nz,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,tv%eqn_of_state, scale=US%kg_m3_to_R) + do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo ! Temperature on tracer 1??? From a14bca056dc06f9a6d708625a850395d28321412 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 14:45:22 -0400 Subject: [PATCH 135/259] Rescaled density units in ISOMIP_initialization.F90 Rescaled density units in ISOMIP_initialize_temperature_salinity, ISOMIP_initialize_thickness and ISOMIP_initialize_sponges for dimensional consistency testing. All answers are bitwise identical. --- src/user/ISOMIP_initialization.F90 | 77 ++++++++++++++++-------------- 1 file changed, 41 insertions(+), 36 deletions(-) diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index eda848fd30..5fb35fa939 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -150,8 +150,9 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read ! positive upward, in depth units [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz, tmp1 real :: x - real :: rho_range - real :: min_thickness, s_sur, s_bot, t_sur, t_bot, rho_sur, rho_bot + real :: min_thickness, s_sur, s_bot, t_sur, t_bot + real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] + real :: rho_range ! The range of densities [R ~> kg m-3] logical :: just_read ! If true, just read parameters but set nothing. character(len=256) :: mesg ! The text of an error message character(len=40) :: verticalCoordinate @@ -183,10 +184,10 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read if (just_read) return ! All run-time parameters have been read, so return. ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state) + call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Surface density is:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state) + call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Bottom density is:', rho_bot ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur @@ -196,11 +197,11 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read ! Construct notional interface positions e0(1) = 0. do K=2,nz - e0(k) = -G%max_depth * ( 0.5 * US%R_to_kg_m3*( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range + e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range e0(k) = min( 0., e0(k) ) ! Bound by surface e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)', & - ! G%max_depth,US%R_to_kg_m3*GV%Rlay(k-1),US%R_to_kg_m3*GV%Rlay(k),e0(k) + ! G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) ! call MOM_mesg(mesg,5) enddo e0(nz+1) = -G%max_depth @@ -263,7 +264,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi !! only read parameters without changing T & S. ! Local variables integer :: i, j, k, is, ie, js, je, nz, itt - real :: x, ds, dt, rho_sur, rho_bot + real :: x, ds, dt + real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: xi0, xi1 ! Heights in depth units [Z ~> m]. real :: S_sur, S_bot ! Salinity at the surface and bottom [ppt] real :: T_sur, T_bot ! Temperature at the bottom [degC] @@ -276,11 +278,13 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi logical :: just_read ! If true, just read parameters but set nothing. logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. real :: T0(SZK_(G)), S0(SZK_(G)) - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [kg m-3]. + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. (zero here) - real :: drho_dT1, drho_dS1, T_Ref, S_Ref + real :: drho_dT1 ! A prescribed derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + real :: drho_dS1 ! A prescribed derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: T_Ref, S_Ref is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke pres(:) = 0.0 @@ -297,10 +301,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & 'Salinity at the bottom (interface)', default=34.55, do_not_log=just_read) - call calculate_density(t_sur,s_sur,0.0,rho_sur,eqn_of_state) + call calculate_density(t_sur,s_sur,0.0,rho_sur,eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Density in the surface layer:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot,s_bot,0.0,rho_bot,eqn_of_state) + call calculate_density(t_bot,s_bot,0.0,rho_bot,eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Density in the bottom layer::', rho_bot ! call MOM_mesg(mesg,5) @@ -328,10 +332,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi default=.false., do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & "Partial derivative of density with salinity.", & - units="kg m-3 PSU-1", fail_if_missing=.not.just_read, do_not_log=just_read) + units="kg m-3 PSU-1", scale=US%kg_m3_to_R, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DT", drho_dT1, & "Partial derivative of density with temperature.", & - units="kg m-3 K-1", fail_if_missing=.not.just_read, do_not_log=just_read) + units="kg m-3 K-1", scale=US%kg_m3_to_R, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_Ref, & "A reference temperature used in initialization.", & units="degC", fail_if_missing=.not.just_read, do_not_log=just_read) @@ -358,36 +362,36 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi ! call MOM_mesg(mesg,5) enddo - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) ! call MOM_mesg(mesg,5) - call calculate_density(T0(1),S0(1),0.,rho_guess(1),eqn_of_state) + call calculate_density(T0(1),S0(1),0.,rho_guess(1),eqn_of_state, scale=US%kg_m3_to_R) if (fit_salin) then ! A first guess of the layers' salinity. do k=nz,1,-1 - S0(k) = max(0.0, S0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dS1) + S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) do k=1,nz - S0(k) = max(0.0, S0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dS1) + S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) enddo enddo else ! A first guess of the layers' temperatures. do k=nz,1,-1 - T0(k) = T0(1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(1)) / drho_dT1 + T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT1 enddo do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) do k=1,nz - T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo endif @@ -407,8 +411,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi ! for debugging !i=G%iec; j=G%jec !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,eqn_of_state) - ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,US%R_to_kg_m3*GV%Rlay(k) + ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,eqn_of_state, scale=US%kg_m3_to_R) + ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo @@ -442,7 +446,8 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) real :: S_sur, T_sur ! Surface salinity and temerature in sponge real :: S_bot, T_bot ! Bottom salinity and temerature in sponge real :: t_ref, s_ref ! reference T and S - real :: rho_sur, rho_bot, rho_range + real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] + real :: rho_range ! The range of densities [R ~> kg m-3] real :: dT_dz, dS_dz ! Gradients of T and S in degC/Z and PPT/Z. real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], usually @@ -520,10 +525,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) enddo ; enddo ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state) + call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state, scale=US%kg_m3_to_R) !write (mesg,*) 'Surface density in sponge:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state) + call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state, scale=US%kg_m3_to_R) !write (mesg,*) 'Bottom density in sponge:', rho_bot ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur @@ -538,11 +543,11 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! Construct notional interface positions e0(1) = 0. do K=2,nz - e0(k) = -G%max_depth * ( 0.5 * US%R_to_kg_m3*( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range + e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range e0(k) = min( 0., e0(k) ) ! Bound by surface e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',& - ! G%max_depth,US%R_to_kg_m3*GV%Rlay(k-1),US%R_to_kg_m3*GV%Rlay(k),e0(k) + ! G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) ! call MOM_mesg(mesg,5) enddo e0(nz+1) = -G%max_depth @@ -604,8 +609,8 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! for debugging !i=G%iec; j=G%jec !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state) - ! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,US%R_to_kg_m3*GV%Rlay(k) + ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state, scale=US%kg_m3_to_R) + ! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo @@ -654,9 +659,9 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) ! for debugging !i=G%iec; j=G%jec !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state) + ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Sponge - k,eta,T,S,rho,Rlay',k,eta(i,j,k),T(i,j,k),& - ! S(i,j,k),rho_tmp,US%R_to_kg_m3*GV%Rlay(k) + ! S(i,j,k),rho_tmp,GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo From fbed637f48092373dcaf5caeba1e7c55731895b3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 14:45:41 -0400 Subject: [PATCH 136/259] Rescaled density units in Rossby_front_2d_init.F90 Rescaled density units in Rossby_front_initialize_thickness and Rossby_front_initialize_velocity for dimensional consistency testing. All answers are bitwise identical. --- src/user/Rossby_front_2d_initialization.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 2ef4dbd644..80b3bc6d94 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -49,7 +49,8 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read integer :: i, j, k, is, ie, js, je, nz real :: Tz, Dml, eta, stretch, h0 - real :: min_thickness, T_range, dRho_dT + real :: min_thickness, T_range + real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: verticalCoordinate @@ -68,7 +69,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='C', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, scale=US%kg_m3_to_R, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -79,7 +80,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read case (REGRIDDING_LAYER, REGRIDDING_RHO) do j = G%jsc,G%jec ; do i = G%isc,G%iec Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / (US%R_to_kg_m3*GV%Rho0) ) * Tz * 0.5 * ( Dml * Dml ) + eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz @@ -90,7 +91,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) do j = G%jsc,G%jec ; do i = G%isc,G%iec Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / (US%R_to_kg_m3*GV%Rho0) ) * Tz * 0.5 * ( Dml * Dml ) + eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz @@ -179,7 +180,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just 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 [L2 Z-1 T-1 degC-1 ~> m s-1 degC-1] - real :: dRho_dT + real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] real :: Dml, zi, zc, zm ! Depths [Z ~> m]. real :: f ! The local Coriolis parameter [T-1 ~> s-1] real :: Ty ! The meridional temperature gradient [degC L-1 ~> degC m-1] @@ -196,7 +197,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='C', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, scale=US%kg_m3_to_R, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -206,7 +207,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 f = 0.5* (G%CoriolisBu(I,j) + G%CoriolisBu(I,j-1) ) dUdT = 0.0 ; if (abs(f) > 0.0) & - dUdT = ( GV%g_Earth*dRho_dT ) / ( f * US%R_to_kg_m3*GV%Rho0 ) + dUdT = ( GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) Dml = Hml( G, G%geoLatT(i,j) ) Ty = US%L_to_m*dTdy( G, T_range, G%geoLatT(i,j) ) zi = 0. From 0a8e67fbbd7eed8ad5e80ee861ba9c15e7e64b9c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 15:13:13 -0400 Subject: [PATCH 137/259] Rescaled density units in benchmark_init.F90 Rescaled density units in benchmark_initialize_thickness and benchmark_init_temperature_salinity for dimensional consistency testing. All answers are bitwise identical. --- src/user/benchmark_initialization.F90 | 44 +++++++++++++++------------ 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 2c40015acd..3478415c60 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -108,13 +108,17 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state real :: T_int ! The initial temperature of an interface [degC]. real :: ML_depth ! The specified initial mixed layer depth, in depth units [Z ~> m]. real :: thermocline_scale ! The e-folding scale of the thermocline, in depth units [Z ~> m]. - real, dimension(SZK_(GV)) :: T0, pres, S0, rho_guess, drho, drho_dT, drho_dS - real :: a_exp ! The fraction of the overall stratification that is exponential. + real, dimension(SZK_(GV)) :: & + T0, pres, S0, & ! drho + rho_guess, & ! Potential density at T0 & S0 [R ~> kg m-3]. + drho_dT, & ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + drho_dS ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: a_exp ! The fraction of the overall stratification that is exponential. real :: I_ts, I_md ! Inverse lengthscales [Z-1 ~> m-1]. - real :: T_frac ! A ratio of the interface temperature to the range - ! between SST and the bottom temperature. + real :: T_frac ! A ratio of the interface temperature to the range + ! between SST and the bottom temperature. real :: err, derr_dz ! The error between the profile's temperature and the - ! interface temperature for a given z and its derivative. + ! interface temperature for a given z and its derivative. real :: pi, z logical :: just_read ! This include declares and sets the variable "version". @@ -147,20 +151,20 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state pres(k) = P_Ref ; S0(k) = 35.0 enddo T0(k1) = 29.0 - call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state) + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, scale=US%kg_m3_to_R) ! A first guess of the layers' temperatures. do k=1,nz - T0(k) = T0(k1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) + T0(k) = T0(k1) + (GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) do k=1,nz - T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo @@ -229,9 +233,9 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & ! Local variables real :: T0(SZK_(G)), S0(SZK_(G)) real :: pres(SZK_(G)) ! Reference pressure [kg m-3]. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [kg m-3 degC-1]. - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [kg m-3 ppt-1]. - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [kg m-3]. + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. real :: PI ! 3.1415926... calculated as 4*atan(1) real :: SST ! The initial sea surface temperature [degC]. real :: lat @@ -252,20 +256,20 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & enddo T0(k1) = 29.0 - call calculate_density(T0(k1),S0(k1),pres(k1),rho_guess(k1),eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,k1,1,eqn_of_state) + call calculate_density(T0(k1),S0(k1),pres(k1),rho_guess(k1),eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,k1,1,eqn_of_state, scale=US%kg_m3_to_R) ! A first guess of the layers' temperatures. ! do k=1,nz - T0(k) = T0(k1) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) + T0(k) = T0(k1) + (GV%Rlay(k) - rho_guess(k1)) / drho_dT(k1) enddo ! Refine the guesses for each layer. ! do itt = 1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) do k=1,nz - T0(k) = T0(k) + (US%R_to_kg_m3*GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo enddo From 15a5cb5f1a410a63f49ce24cd0db37119157cdf0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 16:01:36 -0400 Subject: [PATCH 138/259] Rescaled density units in adjustment_init.F90 Rescaled density units in adjustment_initialize_thickness for dimensional consistency testing. All answers are bitwise identical. --- src/user/adjustment_initialization.F90 | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 94bf004907..bb4102f215 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -47,10 +47,14 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read ! negative because it is positive upward. real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - real :: x, y, yy, delta_S_strat, dSdz, delta_S, S_ref - real :: min_thickness, adjustment_width, adjustment_delta, adjustment_deltaS + real :: dRho_dS ! The partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + ! In this subroutine it is hard coded at 1.0 kg m-3 ppt-1. + real :: x, y, yy + real :: delta_S_strat, dSdz, delta_S, S_ref + real :: min_thickness, adjustment_width, adjustment_delta + real :: adjustment_deltaS real :: front_wave_amp, front_wave_length, front_wave_asym - real :: target_values(SZK_(G)+1) + real :: target_values(SZK_(G)+1) ! Target densities or density anomalies [R ~> kg m-3] logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate ! This include declares and sets the variable "version". @@ -107,6 +111,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) + dRho_dS = 1.0 * US%kg_m3_to_R if (delta_S_strat /= 0.) then ! This was previously coded ambiguously. adjustment_delta = (adjustment_deltaS / delta_S_strat) * G%max_depth @@ -119,12 +124,12 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read e0(k) = -G%max_depth * (real(k-1) / real(nz)) enddo endif - target_values(1) = US%R_to_kg_m3*( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) - target_values(nz+1) = US%R_to_kg_m3*( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) + target_values(1) = ( GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2)) ) + target_values(nz+1) = ( GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) ) do k = 2,nz - target_values(k) = target_values(k-1) + US%R_to_kg_m3*( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) + target_values(k) = target_values(k-1) + ( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) enddo - target_values(:) = target_values(:) - 1000. + target_values(:) = target_values(:) - 1000.*US%kg_m3_to_R do j=js,je ; do i=is,ie if (front_wave_length /= 0.) then y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) @@ -140,8 +145,8 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read x = x * acos( 0. ) delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) do k=2,nz - if (dSdz /= 0.) then - eta1D(k) = ( target_values(k) - ( S_ref + delta_S ) ) / dSdz + if (dRho_dS*dSdz /= 0.) then + eta1D(k) = ( target_values(k) - dRho_dS*( S_ref + delta_S ) ) / (dRho_dS*dSdz) else eta1D(k) = e0(k) - (0.5*adjustment_delta) * sin( x ) endif From e2e4bcb854ea1d85b72cadc3f37e1788b9230d9c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Oct 2019 18:22:31 -0400 Subject: [PATCH 139/259] +Rescaled taux_bot and tauy_bot Rescaled the density part of the units of taux_bot and tauy_bot as passed into btstep and vertvisc for expanded dimensional consistency testing. All answers are bitwise identical, but the units of 4 arguments to 2 public interfaces have changed. --- src/core/MOM_barotropic.F90 | 8 ++++---- src/core/MOM_dynamics_split_RK2.F90 | 4 ++-- src/core/MOM_dynamics_unsplit.F90 | 4 ++-- src/core/MOM_dynamics_unsplit_RK2.F90 | 4 ++-- .../vertical/MOM_vert_friction.F90 | 16 ++++++++-------- 5 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 9c6514aeda..0494e57911 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -444,9 +444,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !! gradient at the start of the barotropic stepping !! [H ~> m or kg m-2]. real, dimension(:,:), optional, pointer :: taux_bot !< The zonal bottom frictional stress from - !! ocean to the seafloor [kg L Z T-2 m-3 ~> Pa]. + !! ocean to the seafloor [R L Z T-2 ~> Pa]. real, dimension(:,:), optional, pointer :: tauy_bot !< The meridional bottom frictional stress - !! from ocean to the seafloor [kg L Z T-2 m-3 ~> Pa]. + !! from ocean to the seafloor [R L Z T-2 ~> Pa]. real, dimension(:,:,:), optional, pointer :: uh0 !< The zonal layer transports at reference !! velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(:,:,:), optional, pointer :: u_uh0 !< The velocities used to calculate @@ -1002,11 +1002,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (associated(taux_bot) .and. associated(tauy_bot)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) + BT_force_u(I,j) = BT_force_u(I,j) - US%R_to_kg_m3*taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) 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) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) + BT_force_v(i,J) = BT_force_v(i,J) - US%R_to_kg_m3*tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) enddo ; enddo endif endif diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 839dcc9f24..3a6e166395 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -124,9 +124,9 @@ module MOM_dynamics_split_RK2 !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean - !! to the seafloor [kg L Z T-2 m-3 ~> Pa] + !! to the seafloor [R L Z T-2 ~> Pa] real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean - !! to the seafloor [kg L Z T-2 m-3 ~> Pa] + !! to the seafloor [R L Z T-2 ~> Pa] type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the !! effective summed open face areas as a function !! of barotropic flow. diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 58d04cff5a..6d91333852 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -116,9 +116,9 @@ module MOM_dynamics_unsplit diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2]. real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean - !! to the seafloor [kg L Z T-2 m-3 ~> Pa] + !! to the seafloor [R L Z T-2 ~> Pa] real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean - !! to the seafloor [kg L Z T-2 m-3 ~> Pa] + !! to the seafloor [R L Z T-2 ~> Pa] logical :: debug !< If true, write verbose checksums for debugging purposes. diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 97ef3ede73..955ddf57e9 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -113,9 +113,9 @@ module MOM_dynamics_unsplit_RK2 diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2]. real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean - !! to the seafloor [kg L Z T-2 m-3 ~> Pa] + !! to the seafloor [R L Z T-2 ~> Pa] real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean - !! to the seafloor [kg L Z T-2 m-3 ~> Pa] + !! to the seafloor [R L Z T-2 ~> Pa] real :: be !< A nondimensional number from 0.5 to 1 that controls !! the backward weighting of the time stepping scheme. diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index a855d88ac2..cfda917a6e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -163,10 +163,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(out) :: taux_bot !< Zonal bottom stress from ocean to - !! rock [kg L Z T-2 m-3 ~> Pa] + !! rock [R L Z T-2 ~> Pa] real, dimension(SZI_(G),SZJB_(G)), & optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to - !! rock [kg L Z T-2 m-3 ~> Pa] + !! rock [R L Z T-2 ~> Pa] type(wave_parameters_CS), & optional, pointer :: Waves !< Container for wave/Stokes information @@ -325,10 +325,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS if (PRESENT(taux_bot)) then do I=Isq,Ieq - taux_bot(I,j) = Rho0 * (u(I,j,nz)*CS%a_u(I,j,nz+1)) + taux_bot(I,j) = US%kg_m3_to_R*Rho0 * (u(I,j,nz)*CS%a_u(I,j,nz+1)) enddo if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq - taux_bot(I,j) = taux_bot(I,j) + Rho0 * (Ray(I,k)*u(I,j,k)) + taux_bot(I,j) = taux_bot(I,j) + US%kg_m3_to_R*Rho0 * (Ray(I,k)*u(I,j,k)) enddo ; enddo ; endif endif @@ -406,10 +406,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS if (present(tauy_bot)) then do i=is,ie - tauy_bot(i,J) = Rho0 * (v(i,J,nz)*CS%a_v(i,J,nz+1)) + tauy_bot(i,J) = US%kg_m3_to_R*Rho0 * (v(i,J,nz)*CS%a_v(i,J,nz+1)) enddo if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie - tauy_bot(i,J) = tauy_bot(i,J) + Rho0 * (Ray(i,k)*v(i,J,k)) + tauy_bot(i,J) = tauy_bot(i,J) + US%kg_m3_to_R*Rho0 * (Ray(i,k)*v(i,J,k)) enddo ; enddo ; endif endif @@ -1732,10 +1732,10 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%L_T2_to_m_s2*US%Z_to_m) + conversion=US%R_to_kg_m3*US%L_T2_to_m_s2*US%Z_to_m) CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%L_T2_to_m_s2*US%Z_to_m) + conversion=US%R_to_kg_m3*US%L_T2_to_m_s2*US%Z_to_m) if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) From a6692941149cd87c8031debccf1c9eb9a32110d1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Oct 2019 10:44:49 -0400 Subject: [PATCH 140/259] +Rescaled density units in coord_rho.F90 Optionally rescaled density units in coord_rho for dimensional consistency testing, as determined by the presence and value of a new optional argument, rho_scale, to init_coord_rho. All answers are bitwise identical. --- src/ALE/coord_rho.F90 | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 74af5813eb..53b83644af 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -26,9 +26,12 @@ module coord_rho !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .false. - !> Nominal density of interfaces [kg m-3] + !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density + !> Density scaling factor [R m3 kg-1 ~> 1] + real :: kg_m3_to_R + !> Interpolation control structure type(interp_CS_type) :: interp_CS end type rho_CS @@ -43,12 +46,13 @@ module coord_rho contains !> Initialise a rho_CS with pointers to parameters -subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) +subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS, rho_scale) type(rho_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in the grid real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] - real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [kg m-3] + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [kg m-3 or R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation + real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density if (associated(CS)) call MOM_error(FATAL, "init_coord_rho: CS already associated!") allocate(CS) @@ -58,6 +62,8 @@ subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) CS%ref_pressure = ref_pressure CS%target_density(:) = target_density(:) CS%interp_CS = interp_CS + CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale + end subroutine init_coord_rho !> This subroutine deallocates memory in the control structure for the coord_rho module @@ -111,7 +117,8 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & ! Local variables integer :: k, count_nonzero_layers integer, dimension(nz) :: mapping - real, dimension(nz) :: p, densities, h_nv + real, dimension(nz) :: p, h_nv + real, dimension(nz) :: densities ! Layer density [R ~> kg m-3] real, dimension(nz+1) :: xTmp real, dimension(CS%nk) :: h_new ! New thicknesses real, dimension(CS%nk+1) :: x1 @@ -127,7 +134,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & ! Compute densities on source column p(:) = CS%ref_pressure - call calculate_density(T, S, p, densities, 1, nz, eqn_of_state) + call calculate_density(T, S, p, densities, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) enddo @@ -238,8 +245,8 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ enddo ! Compute densities within current water column - call calculate_density( T_tmp, S_tmp, p, densities,& - 1, nz, eqn_of_state ) + call calculate_density( T_tmp, S_tmp, p, densities, & + 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) From 1cbf498b791827ef12477a351d1354871c69f9fe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Oct 2019 14:26:15 -0400 Subject: [PATCH 141/259] +Rescaled units of forces%taux to [R Z L T-2] Rescaled the units for the wind stresses, forces%taux and fluxes%tauy, from [Pa] to [R Z L T-2], for expanded dimensional consistency testing. All answers are bitwise identical, but there are changes in the dimensions of two elements in a transparent public type. Some changes in the mct_driver and the nuopc_driver are not well tested, but are analogous to changes in well-tested code. --- .../MOM_surface_forcing_gfdl.F90 | 61 ++++++++++--------- .../ice_solo_driver/MOM_surface_forcing.F90 | 30 +++++---- .../ice_solo_driver/user_surface_forcing.F90 | 9 +-- .../mct_driver/mom_surface_forcing_mct.F90 | 32 ++++++---- .../mom_surface_forcing_nuopc.F90 | 32 ++++++---- .../solo_driver/MOM_surface_forcing.F90 | 48 +++++++++------ .../solo_driver/Neverland_surface_forcing.F90 | 7 ++- .../solo_driver/user_surface_forcing.F90 | 7 ++- src/core/MOM_barotropic.F90 | 13 ++-- src/core/MOM_forcing_type.F90 | 21 ++++--- .../vertical/MOM_set_viscosity.F90 | 12 ++-- .../vertical/MOM_vert_friction.F90 | 8 +-- src/user/Idealized_Hurricane.F90 | 20 +++--- src/user/SCM_CVMix_tests.F90 | 14 +++-- 14 files changed, 179 insertions(+), 135 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 4102bba491..19c137567a 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -862,9 +862,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a !! previous call to surface_forcing_init. real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(inout) :: taux !< The zonal wind stresses on a C-grid [Pa]. + optional, intent(inout) :: taux !< The zonal wind stresses on a C-grid [R Z L T-2 ~> Pa]. real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(inout) :: tauy !< The meridional wind stresses on a C-grid [Pa]. + optional, intent(inout) :: tauy !< The meridional wind stresses on a C-grid [R Z L T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(inout) :: ustar !< The surface friction velocity [Z T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), & @@ -873,17 +873,18 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: taux_in_A ! Zonal wind stresses [Pa] at h points - real, dimension(SZI_(G),SZJ_(G)) :: tauy_in_A ! Meridional wind stresses [Pa] at h points + real, dimension(SZI_(G),SZJ_(G)) :: taux_in_A ! Zonal wind stresses [R Z L T-2 ~> Pa] at h points + real, dimension(SZI_(G),SZJ_(G)) :: tauy_in_A ! Meridional wind stresses [R Z L T-2 ~> Pa] at h points real, dimension(SZIB_(G),SZJ_(G)) :: taux_in_C ! Zonal wind stresses [Pa] at u points - real, dimension(SZI_(G),SZJB_(G)) :: tauy_in_C ! Meridional wind stresses [Pa] at v points + real, dimension(SZI_(G),SZJB_(G)) :: tauy_in_C ! Meridional wind stresses [R Z L T-2 ~> Pa] at v points real, dimension(SZIB_(G),SZJB_(G)) :: taux_in_B ! Zonal wind stresses [Pa] at q points - real, dimension(SZIB_(G),SZJB_(G)) :: tauy_in_B ! Meridional wind stresses [Pa] at q points + real, dimension(SZIB_(G),SZJB_(G)) :: tauy_in_B ! Meridional wind stresses [R Z L T-2 ~> Pa] at q points - real :: gustiness ! unresolved gustiness that contributes to ustar [Pa] + real :: gustiness ! unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] real :: Irho0 ! Inverse of the mean density rescaled to [Z2 s2 m T-2 kg-1 ~> m3 kg-1] - real :: taux2, tauy2 ! squared wind stresses [Pa2] - real :: tau_mag ! magnitude of the wind stress [Pa] + real :: taux2, tauy2 ! squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] + real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] logical :: do_ustar, do_gustless integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) @@ -896,6 +897,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, i0 = is - index_bounds(1) ; j0 = js - index_bounds(3) Irho0 = (US%m_to_Z*US%T_to_s)**2 / CS%Rho0 + stress_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * CS%wind_stress_multiplier do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) @@ -916,8 +918,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then do J=js,je ; do I=is,ie - taux_in_B(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - tauy_in_B(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + taux_in_B(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion + tauy_in_B(I,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion enddo ; enddo endif @@ -942,8 +944,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, taux_in_A(:,:) = 0.0 ; tauy_in_A(:,:) = 0.0 if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then do j=js,je ; do i=is,ie - taux_in_A(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - tauy_in_A(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + taux_in_A(i,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + tauy_in_A(i,j) = IOB%v_flux(i-i0,j-j0) * stress_conversion enddo ; enddo endif @@ -971,8 +973,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, taux_in_C(:,:) = 0.0 ; tauy_in_C(:,:) = 0.0 if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then do j=js,je ; do i=is,ie - taux_in_C(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - tauy_in_C(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + taux_in_C(I,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + tauy_in_C(i,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion enddo ; enddo endif @@ -1029,11 +1031,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(tau_mag / CS%Rho0) + if (do_gustless) gustless_ustar(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) endif enddo ; enddo elseif (wind_stagger == AGRID) then @@ -1041,11 +1043,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(tau_mag / CS%Rho0) + if (do_gustless) gustless_ustar(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) endif enddo ; enddo else ! C-grid wind stresses. @@ -1062,11 +1064,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust_const if (CS%read_gust_2d) gustiness = CS%gust(i,j) - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(tau_mag / CS%Rho0) + if (do_gustless) gustless_ustar(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) endif enddo ; enddo endif ! endif for wind friction velocity fields @@ -1132,12 +1134,15 @@ subroutine apply_force_adjustments(G, CS, Time, forces) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points [Pa] - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points [Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] integer :: isc, iec, jsc, jec, i, j real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau logical :: overrode_x, overrode_y + type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type + + US => G%US isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec @@ -1160,8 +1165,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = tempx_at_h(i,j) - merid_tau = tempy_at_h(i,j) + zonal_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempx_at_h(i,j) + merid_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index ad2352d460..b6c48ca52c 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -389,8 +389,8 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) PI = 4.0*atan(1.0) do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.1*(1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / & - CS%len_lat)) + forces%taux(I,j) = 0.1*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie @@ -426,7 +426,8 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) PI = 4.0*atan(1.0) do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) =-0.2*cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) + forces%taux(I,j) = -0.2*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie @@ -464,9 +465,9 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) do j=jsd,jed ; do I=IsdB,IedB y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - forces%taux(I,j) = CS%gyres_taux_const + & + forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * (CS%gyres_taux_const + & ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & - + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) ) + + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) )) enddo ; enddo do J=JsdB,JedB ; do i=isd,ied @@ -477,7 +478,7 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) do j=js,je ; do i=is,ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & - forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%taux(i,j)*forces%taux(i,j)))* US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L /CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo call callTree_leave("wind_forcing_gyres") @@ -528,10 +529,12 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.5 * CS%wind_scale * (temp_x(i,j) + temp_x(i+1,j)) + forces%taux(I,j) = 0.5 * CS%wind_scale * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (temp_x(i,j) + temp_x(i+1,j)) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.5 * CS%wind_scale * (temp_y(i,j) + temp_y(i,j+1)) + forces%tauy(i,J) = 0.5 * CS%wind_scale * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (temp_y(i,j) + temp_y(i,j+1)) enddo ; enddo if (CS%read_gust_2d) then @@ -548,7 +551,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) case ("C") call MOM_read_vector(filename,CS%stress_x_var, CS%stress_y_var, & forces%taux(:,:), forces%tauy(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%wind_scale /= 1.0) then do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = CS%wind_scale * forces%taux(I,j) @@ -561,15 +565,15 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) if (CS%read_gust_2d) then do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & + forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L * & + sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & forces%taux(i,j)**2))) + CS%gust(i,j)) / CS%Rho0 ) enddo ; enddo else do j=js, je ; do i=is, ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) * & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo endif case default diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 1652db2ceb..53ed835af9 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -91,7 +91,7 @@ module user_surface_forcing contains -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [Pa]. +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [R Z L T-2 ~> Pa]. !! These are the stresses in the direction of the model grid (i.e. the same !! direction as the u- and v- velocities). subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) @@ -104,7 +104,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned !! by a previous call to user_surface_forcing_init -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy [Pa]. +! This subroutine sets the surface wind stresses, forces%taux and forces%tauy [R Z L T-2 ~> Pa]. ! In addition, this subroutine can be used to set the surface friction velocity, ! forces%ustar [Z T-1 ~> m s-1], which is needed with a bulk mixed layer. @@ -130,7 +130,8 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 ! Change this to the desired expression. + ! Change this to the desired expression. + forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. @@ -140,7 +141,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) enddo ; enddo ; endif diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index d43f9f064b..86bc54e6e1 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -710,8 +710,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * & + US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z*CS%wind_stress_multiplier + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * & + US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z*CS%wind_stress_multiplier endif enddo ; enddo @@ -725,7 +727,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & + forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo; enddo @@ -733,7 +736,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & + forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo; enddo @@ -762,7 +766,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & + forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo; enddo @@ -770,7 +775,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & + forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo; enddo @@ -799,9 +805,11 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + & + Irho0*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(taux2 + tauy2)) else - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + & + Irho0*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(taux2 + tauy2)) endif enddo; enddo @@ -913,8 +921,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h !< Delta to zonal wind stress at h points [Pa] - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h !< Delta to meridional wind stress at h points [Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h !< Delta to zonal wind stress at h points [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h !< Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] integer :: isc, iec, jsc, jec, i, j real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau @@ -941,8 +949,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = tempx_at_h(i,j) - merid_tau = tempy_at_h(i,j) + zonal_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempx_at_h(i,j) + merid_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index cdd93a8772..bd4ff4e0e8 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -707,8 +707,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * & + US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * & + US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * CS%wind_stress_multiplier endif enddo ; enddo @@ -722,7 +724,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & + forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo @@ -730,7 +733,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & + forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo @@ -759,7 +763,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & + forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo @@ -767,7 +772,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & + forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo @@ -796,9 +802,11 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*Irho0*sqrt(taux2 + tauy2)) else - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo @@ -909,8 +917,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h !< Delta to zonal wind stress at h points [Pa] - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h !< Delta to meridional wind stress at h points [Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h !< Delta to zonal wind stress at h points [R Z L T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h !< Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] integer :: isc, iec, jsc, jec, i, j real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau @@ -937,8 +945,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = tempx_at_h(i,j) - merid_tau = tempy_at_h(i,j) + zonal_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempx_at_h(i,j) + merid_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 442047f03c..19995caab7 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -379,14 +379,15 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB !set steady surface wind stresses, in units of Pa. + !### mag_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * sqrt( tau_x0**2 + tau_y0**2) mag_tau = sqrt( tau_x0**2 + tau_y0**2) do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = tau_x0 + forces%taux(I,j) = tau_x0 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z enddo ; enddo do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = tau_y0 + forces%tauy(i,J) = tau_y0 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z enddo ; enddo if (CS%read_gust_2d) then @@ -425,8 +426,8 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) PI = 4.0*atan(1.0) do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = 0.1*(1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / & - CS%len_lat)) + forces%taux(I,j) = 0.1*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) enddo ; enddo do J=js-1,Jeq ; do i=is,ie @@ -459,7 +460,8 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) PI = 4.0*atan(1.0) do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) =-0.2*cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) + forces%taux(I,j) = -0.2*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) enddo ; enddo do J=js-1,Jeq ; do i=is,ie @@ -492,9 +494,10 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) do j=js-1,je+1 ; do I=is-1,Ieq y = (G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat - forces%taux(I,j) = CS%gyres_taux_const + & + forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + (CS%gyres_taux_const + & ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & - + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) ) + + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) )) enddo ; enddo do J=js-1,Jeq ; do i=is-1,ie+1 @@ -506,14 +509,16 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) do j=js,je ; do i=is,ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & - forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%taux(i,j)*forces%taux(i,j))) * & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo else I_rho = 1.0 / CS%Rho0 do j=js,je ; do i=is,ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( (CS%gust_const + & sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) * & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L ) * I_rho ) enddo ; enddo endif @@ -583,7 +588,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), & - G%Domain, stagger=AGRID, timelevel=time_lev) + G%Domain, stagger=AGRID, timelevel=time_lev, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=js,je ; do I=is-1,Ieq @@ -597,12 +603,12 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (CS%read_gust_2d) then do j=js,je ; do i=is,ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) + temp_y(i,j)*temp_y(i,j))*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L + CS%gust(i,j)) / CS%Rho0) enddo ; enddo else do j=js,je ; do i=is,ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + temp_y(i,j)*temp_y(i,j)) * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo endif endif @@ -616,7 +622,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), & - G%Domain_aux, stagger=CGRID_NE, timelevel=time_lev) + G%Domain_aux, stagger=CGRID_NE, timelevel=time_lev, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) do j=js,je ; do i=is,ie forces%taux(I,j) = CS%wind_scale * temp_x(I,j) forces%tauy(i,J) = CS%wind_scale * temp_y(i,J) @@ -625,7 +632,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) else call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & forces%taux(:,:), forces%tauy(:,:), & - G%Domain, stagger=CGRID_NE, timelevel=time_lev) + G%Domain, stagger=CGRID_NE, timelevel=time_lev, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%wind_scale /= 1.0) then do j=js,je ; do I=Isq,Ieq @@ -642,14 +650,14 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (CS%read_gust_2d) then do j=js, je ; do i=is, ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2))) + CS%gust(i,j)) / CS%Rho0 ) + forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) * & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L + CS%gust(i,j)) / CS%Rho0 ) enddo ; enddo else do j=js, je ; do i=is, ie forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) * & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo endif endif @@ -707,10 +715,10 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) ! Ignore CS%wind_scale when using data_override ????? do j=G%jsc,G%jec ; do I=G%isc-1,G%IecB - forces%taux(I,j) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) + forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * 0.5 * (temp_x(i,j) + temp_x(i+1,j)) enddo ; enddo do J=G%jsc-1,G%JecB ; do i=G%isc,G%iec - forces%tauy(i,J) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) + forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * 0.5 * (temp_y(i,j) + temp_y(i,j+1)) enddo ; enddo read_Ustar = (len_trim(CS%ustar_var) > 0) ! Need better control higher up ???? diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index be29466e14..d8cf2ccddc 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -61,7 +61,8 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB real :: x, y real :: PI - real :: tau_max, off + real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: off is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -78,7 +79,7 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) ! calculation of ustar - otherwise the lower bound would be Isq. PI = 4.0*atan(1.0) forces%taux(:,:) = 0.0 - tau_max = 0.2 + tau_max = 0.2 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z off = 0.02 do j=js,je ; do I=is-1,Ieq ! x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon @@ -105,7 +106,7 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) ! if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! ! This expression can be changed if desired, but need not be. ! forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & -! sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & +! US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & ! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) ! enddo ; enddo ; endif diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 92151e6cde..8660d59256 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -45,7 +45,7 @@ module user_surface_forcing contains -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [Pa]. +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [R Z L T-2 ~> Pa]. !! These are the stresses in the direction of the model grid (i.e. the same !! direction as the u- and v- velocities). subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) @@ -78,7 +78,8 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 ! Change this to the desired expression. + ! Change this to the desired expression. + forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. @@ -89,7 +90,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) enddo ; enddo ; endif diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0494e57911..0fdd8c935d 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -580,9 +580,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZIW_(CS),SZJBW_(CS)) :: & vbt_prev, vhbt_prev, vbt_sum_prev, vhbt_sum_prev, vbt_wtd_prev ! for OBC - real :: mass_to_Z ! The depth unit converison divided by the mean density (Rho0) [Z m2 kg-1 ~> m3 kg-1]. - real :: mass_accel_to_Z ! The depth unit converison times an acceleration conversion divided by - ! the mean density (Rho0) [Z L m s2 T-2 kg-1 ~> m3 kg-1]. + real :: mass_to_Z ! The depth unit converison divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. + real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: dtbt ! The barotropic time step [T ~> s]. @@ -724,8 +723,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dtbt = dt_in_T * Instep bebt = CS%bebt be_proj = CS%bebt - mass_accel_to_Z = US%m_to_L*US%T_to_s**2 * US%m_to_Z / (US%R_to_kg_m3*GV%Rho0) - mass_to_Z = US%m_to_Z / (US%R_to_kg_m3*GV%Rho0) + mass_accel_to_Z = 1.0 / GV%Rho0 + mass_to_Z = US%m_to_Z / (GV%Rho0) !--- setup the weight when computing vbt_trans and ubt_trans if (project_velocity) then @@ -1002,11 +1001,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (associated(taux_bot) .and. associated(tauy_bot)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - BT_force_u(I,j) = BT_force_u(I,j) - US%R_to_kg_m3*taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) + BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) 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) - US%R_to_kg_m3*tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) + BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) enddo ; enddo endif endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ececc6d1e7..a51219bb1f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -185,8 +185,8 @@ module MOM_forcing_type type, public :: mech_forcing ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & - taux => NULL(), & !< zonal wind stress [Pa] - tauy => NULL(), & !< meridional wind stress [Pa] + taux => NULL(), & !< zonal wind stress [R L Z T-2 ~> Pa] + tauy => NULL(), & !< meridional wind stress [R L Z T-2 ~> Pa] ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. net_mass_src => NULL() !< The net mass source to the ocean [kg m-2 s-1]. @@ -1102,7 +1102,7 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! and js...je as their extent. if (associated(forces%taux) .and. associated(forces%tauy)) & call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & - haloshift=hshift, symmetric=.true.) + haloshift=hshift, symmetric=.true., scale=US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L) if (associated(forces%p_surf)) & call hchksum(forces%p_surf, mesg//" forces%p_surf",G%HI,haloshift=hshift) if (associated(forces%ustar)) & @@ -1215,13 +1215,15 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_taux = register_diag_field('ocean_model', 'taux', diag%axesCu1, Time, & - 'Zonal surface stress from ocean interactions with atmos and ice', 'Pa', & + 'Zonal surface stress from ocean interactions with atmos and ice', & + 'Pa', conversion=US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L, & standard_name='surface_downward_x_stress', cmor_field_name='tauuo', & cmor_units='N m-2', cmor_long_name='Surface Downward X Stress', & cmor_standard_name='surface_downward_x_stress') handles%id_tauy = register_diag_field('ocean_model', 'tauy', diag%axesCv1, Time, & - 'Meridional surface stress ocean interactions with atmos and ice', 'Pa', & + 'Meridional surface stress ocean interactions with atmos and ice', & + 'Pa', conversion=US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L, & standard_name='surface_downward_y_stress', cmor_field_name='tauvo', & cmor_units='N m-2', cmor_long_name='Surface Downward Y Stress', & cmor_standard_name='surface_downward_y_stress') @@ -2050,6 +2052,7 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) end subroutine copy_common_forcing_fields +!### Change the units of Rho0 passed to set_derived_forcing_fields. !> This subroutine calculates certain derived forcing fields based on information !! from a mech_forcing type and stores them in a (thermodynamic) forcing type. @@ -2061,12 +2064,12 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) real, intent(in) :: Rho0 !< A reference density of seawater [kg m-3], !! as used to calculate ustar. - real :: taux2, tauy2 ! Squared wind stress components [Pa2]. - real :: Irho0 ! Inverse of the mean density rescaled to [Z2 m / kg ~> m3 kg-1] + real :: taux2, tauy2 ! Squared wind stress components [R2 L2 Z2 T-4 ~> Pa2]. + real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Irho0 = US%m_to_Z**2 / Rho0 + Irho0 = US%L_to_Z / (US%kg_m3_to_R*Rho0) if (associated(forces%taux) .and. associated(forces%tauy) .and. & associated(fluxes%ustar_gustless)) then @@ -2082,7 +2085,7 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - fluxes%ustar_gustless(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(taux2 + tauy2) / Rho0) + fluxes%ustar_gustless(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) !### Change to: ! fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index c3985e2a7d..d9743d2240 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1087,7 +1087,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym ! viscous mixed layer, including reduction for turbulent ! decay. Nondimensional. real :: dt_Rho0 ! The time step divided by the conversion from the layer - ! thickness to layer mass [s H m2 kg-1 ~> s m3 kg-1 or s]. + ! thickness to layer mass [T H Z-1 R-1 ~> s m3 kg-1 or s]. real :: g_H_Rho0 ! The gravitational acceleration times the conversion from H to m divided ! by the mean density [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: ustarsq ! 400 times the square of ustar, times @@ -1141,7 +1141,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym OBC => CS%OBC use_EOS = associated(tv%eqn_of_state) - dt_Rho0 = US%T_to_s*dt_in_T / GV%H_to_kg_m2 + dt_Rho0 = dt_in_T / GV%H_to_RZ h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (GV%Rho0) @@ -1205,8 +1205,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym do_i(I) = .true. ; do_any = .true. k_massive(I) = nkml Thtot(I) = 0.0 ; Shtot(I) = 0.0 ; Rhtot(i) = 0.0 - uhtot(I) = US%m_s_to_L_T*dt_Rho0 * forces%taux(I,j) - vhtot(I) = 0.25 * US%m_s_to_L_T*dt_Rho0 * ((forces%tauy(i,J) + forces%tauy(i+1,J-1)) + & + uhtot(I) = dt_Rho0 * forces%taux(I,j) + vhtot(I) = 0.25 * dt_Rho0 * ((forces%tauy(i,J) + forces%tauy(i+1,J-1)) + & (forces%tauy(i,J-1) + forces%tauy(i+1,J))) if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else @@ -1440,8 +1440,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym do_i(i) = .true. ; do_any = .true. k_massive(i) = nkml Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; Rhtot(i) = 0.0 - vhtot(i) = US%m_s_to_L_T*dt_Rho0 * forces%tauy(i,J) - uhtot(i) = 0.25 * US%m_s_to_L_T*dt_Rho0 * ((forces%taux(I,j) + forces%taux(I-1,j+1)) + & + vhtot(i) = dt_Rho0 * forces%tauy(i,J) + uhtot(i) = 0.25 * dt_Rho0 * ((forces%taux(I,j) + forces%taux(I-1,j+1)) + & (forces%taux(I-1,j) + forces%taux(I,j+1))) if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index cfda917a6e..8f9b694853 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -186,7 +186,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS ! is applied with direct_stress [H ~> m or kg m-2]. real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. - real :: dt_Rho0 ! The time step divided by the mean density [L s2 H m T-1 kg-1 ~> s m3 kg-1 or s]. + real :: dt_Rho0 ! The time step divided by the mean density [T H Z-1 R-1 ~> s m3 kg-1 or s]. real :: Rho0 ! A density used to convert drag laws into stress in Pa [kg m-3]. real :: dt_Z_to_H ! The time step times the conversion from Z to the ! units of thickness - [T H Z-1 ~> s or s kg m-3]. @@ -213,7 +213,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS Hmix = CS%Hmix_stress I_Hmix = 1.0 / Hmix endif - dt_Rho0 = US%m_s_to_L_T*US%T_to_s * dt_in_T / GV%H_to_kg_m2 + dt_Rho0 = dt_in_T / GV%H_to_RZ dt_Z_to_H = dt_in_T*GV%Z_to_H Rho0 = US%R_to_kg_m3*GV%Rho0 h_neglect = GV%H_subroundoff @@ -1328,7 +1328,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U real :: truncvel ! are truncated to truncvel, both [L T-1 ~> m s-1]. real :: CFL ! The local CFL number. real :: H_report ! A thickness below which not to report truncations. - real :: dt_Rho0 ! The timestep divided by the Boussinesq density [s m3 kg-1]. + real :: dt_Rho0 ! The timestep divided by the Boussinesq density [m2 T2 s-1 L-1 Z-1 R-1 ~> s m3 kg-1]. real :: vel_report(SZIB_(G),SZJB_(G)) ! The velocity to report [L T-1 ~> m s-1] real :: u_old(SZIB_(G),SZJ_(G),SZK_(G)) ! The previous u-velocity [L T-1 ~> m s-1] real :: v_old(SZI_(G),SZJB_(G),SZK_(G)) ! The previous v-velocity [L T-1 ~> m s-1] @@ -1340,7 +1340,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U maxvel = CS%maxvel truncvel = 0.9*maxvel H_report = 6.0 * GV%Angstrom_H - dt_Rho0 = US%T_to_s*dt_in_T / (US%R_to_kg_m3*GV%Rho0) + dt_Rho0 = (US%L_T_to_m_s*US%Z_to_m) * dt_in_T / (GV%Rho0) if (len_trim(CS%u_trunc_file) > 0) then !$OMP parallel do default(shared) private(trunc_any,CFL) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 730551ccdb..18b21eef3e 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -269,9 +269,8 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) YY = LAT - YC XX = LON - XC endif - call idealized_hurricane_wind_profile(& - CS,f,YY,XX,Uocn,Vocn,TX,TY) - forces%taux(I,j) = G%mask2dCu(I,j) * TX + call idealized_hurricane_wind_profile(CS,f,YY,XX,Uocn,Vocn,TX,TY) + forces%taux(I,j) = G%mask2dCu(I,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * TX enddo enddo !> Computes tauy @@ -292,7 +291,7 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) XX = LON - XC endif call idealized_hurricane_wind_profile(CS, f, YY, XX, Uocn, Vocn, TX, TY) - forces%tauy(i,J) = G%mask2dCv(i,J) * TY + forces%tauy(i,J) = G%mask2dCv(i,J) * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * TY enddo enddo @@ -301,8 +300,9 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) do i=is,ie ! This expression can be changed if desired, but need not be. forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gustiness/CS%Rho0 + & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L * & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) enddo enddo @@ -433,7 +433,6 @@ subroutine idealized_hurricane_wind_profile(CS, absf, YY, XX, UOCN, VOCN, Tx, Ty TX = CS%rho_A * Cd * sqrt(du**2 + dV**2) * dU TY = CS%rho_A * Cd * sqrt(du**2 + dV**2) * dV - return end subroutine idealized_hurricane_wind_profile !> This subroutine is primarily needed as a legacy for reproducing answers. @@ -579,7 +578,8 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) else Cd = 0.0018 endif - forces%taux(I,j) = CS%rho_a * G%mask2dCu(I,j) * Cd*sqrt(du**2+dV**2)*dU + forces%taux(I,j) = CS%rho_a * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + G%mask2dCu(I,j) * Cd*sqrt(du**2+dV**2)*dU enddo ; enddo !/BR ! See notes above @@ -597,16 +597,18 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) else Cd = 0.0018 endif - forces%tauy(I,j) = CS%rho_a * G%mask2dCv(I,j) * Cd*du10*dV + forces%tauy(I,j) = CS%rho_a * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & + G%mask2dCv(I,j) * Cd*du10*dV enddo ; enddo ! Set the surface friction velocity [m s-1]. ustar is always positive. do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gustiness/CS%Rho0 + & + US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L * & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) enddo ; enddo - return + end subroutine SCM_idealized_hurricane_wind_forcing end module idealized_hurricane diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 48c4dc229d..8c2d3359e6 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -131,8 +131,12 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) type(param_file_type), intent(in) :: param_file !< Input parameter structure type(SCM_CVMix_tests_CS), pointer :: CS !< Parameter container -! This include declares and sets the variable "version". -#include "version_variable.h" + + ! This include declares and sets the variable "version". +# include "version_variable.h" + type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type + + US => G%US if (associated(CS)) then call MOM_error(FATAL, "SCM_CVMix_tests_surface_forcing_init called with an associated "// & @@ -163,11 +167,11 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) call get_param(param_file, mdl, "SCM_TAU_X", & CS%tau_x, "Constant X-dir wind stress "// & "used in the SCM CVMix test surface forcing.", & - units='N/m2', fail_if_missing=.true.) + units='N/m2', scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, fail_if_missing=.true.) call get_param(param_file, mdl, "SCM_TAU_Y", & CS%tau_y, "Constant y-dir wind stress "// & "used in the SCM CVMix test surface forcing.", & - units='N/m2', fail_if_missing=.true.) + units='N/m2', scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, fail_if_missing=.true.) endif if (CS%UseHeatFlux) then call get_param(param_file, mdl, "SCM_HEAT_FLUX", & @@ -218,7 +222,7 @@ subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( mag_tau / CS%Rho0 ) + forces%ustar(i,j) = sqrt( US%R_to_kg_m3*US%L_to_Z * mag_tau / CS%Rho0 ) enddo ; enddo ; endif end subroutine SCM_CVMix_tests_wind_forcing From 3db79cd3539ae5745863410311c7723036c66ef5 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 3 Oct 2019 18:24:14 -0400 Subject: [PATCH 142/259] MEKE diagnostic array fixes This patch fixes the following MEKE diagnostics: - MEKE_Ue, MEKE_Ub, MEKE_Ut The diagnostics were computed as inline operations inside post_data, e.g.: post_data(..., sqrt(0, max(0., MEKE*bottomFac2))) rather than computing the fields explicitly inside of array loops. This case causing floating point exceptions in Intel compilers, possibly likely due to evaluations inside of halos. We resolve these diagnostics by computing the values into a scratch array which is then passed to post_data. --- src/parameterizations/lateral/MOM_MEKE.F90 | 28 ++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index dc44601f71..10ff97fc06 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -128,7 +128,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h del4MEKE, & ! Time-integrated MEKE tendency arising from the biharmonic of MEKE [L2 T-2 ~> m2 s-2]. LmixScale, & ! Eddy mixing length [L ~> m]. barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] - bottomFac2 ! Ratio of EKE_bottom / EKE [nondim] + bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] + tmp ! Temporary variable for diagnostic computation real, dimension(SZIB_(G),SZJ_(G)) :: & MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with different units in different @@ -575,10 +576,29 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! Offer fields for averaging. + + if (any([CS%id_Ue, CS%id_Ub, CS%id_Ut] > 0)) & + tmp(:,:) = 0. + if (CS%id_MEKE>0) call post_data(CS%id_MEKE, MEKE%MEKE, CS%diag) - if (CS%id_Ue>0) call post_data(CS%id_Ue, sqrt(max(0.,2.0*MEKE%MEKE)), CS%diag) - if (CS%id_Ub>0) call post_data(CS%id_Ub, sqrt(max(0.,2.0*MEKE%MEKE*bottomFac2)), CS%diag) - if (CS%id_Ut>0) call post_data(CS%id_Ut, sqrt(max(0.,2.0*MEKE%MEKE*barotrFac2)), CS%diag) + if (CS%id_Ue>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j))) + enddo ; enddo + call post_data(CS%id_Ue, tmp, CS%diag) + endif + if (CS%id_Ub>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * bottomFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ub, tmp, CS%diag) + endif + if (CS%id_Ut>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * barotrFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ut, tmp, CS%diag) + endif if (CS%id_Kh>0) call post_data(CS%id_Kh, MEKE%Kh, CS%diag) if (CS%id_Ku>0) call post_data(CS%id_Ku, MEKE%Ku, CS%diag) if (CS%id_Au>0) call post_data(CS%id_Au, MEKE%Au, CS%diag) From 79d004b6a0e2872bab3a444ef205e503349a2746 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Oct 2019 18:32:02 -0400 Subject: [PATCH 143/259] Rescaled gustiness in MOM_surface_forcing files Rescaled gust_const and Rho0 in the various MOM_surface_forcing files for dimensional consistency testing and to simplify some expressions in the code. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 72 +++++----- .../ice_solo_driver/MOM_surface_forcing.F90 | 73 +++++----- .../mct_driver/mom_surface_forcing_mct.F90 | 92 ++++++------ .../mom_surface_forcing_nuopc.F90 | 86 ++++++------ .../solo_driver/MOM_surface_forcing.F90 | 131 +++++++++--------- .../solo_driver/Neverland_surface_forcing.F90 | 7 +- .../solo_driver/user_surface_forcing.F90 | 28 ++-- src/user/Idealized_Hurricane.F90 | 38 +++-- src/user/SCM_CVMix_tests.F90 | 3 +- 9 files changed, 269 insertions(+), 261 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 19c137567a..c91bde8fc6 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -66,7 +66,7 @@ module MOM_surface_forcing_gfdl logical :: use_temperature !< If true, temp and saln used as state variables real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. - real :: Rho0 !< Boussinesq reference density [kg m-3] + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: area_surf = -1.0 !< Total ocean surface area [m2] real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] real :: latent_heat_vapor !< Latent heat of vaporization [J kg-1] @@ -85,14 +85,14 @@ module MOM_surface_forcing_gfdl !! type without any further adjustments to drive the ocean dynamics. !! The actual net mass source may differ due to corrections. - real :: gust_const !< Constant unresolved background gustiness for ustar [Pa] + real :: gust_const !< Constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL() !< Turbulent kinetic energy introduced to the bottom boundary layer !! by drag on the tidal flows [W m-2]. real, pointer, dimension(:,:) :: & gust => NULL() !< A spatially varying unresolved background gustiness that - !! contributes to ustar [Pa]. gust is used when read_gust_2d is true. + !! contributes to ustar [R L Z T-1 ~> Pa]. gust is used when read_gust_2d is true. real, pointer, dimension(:,:) :: & ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [m s-1] real :: cd_tides !< Drag coefficient that applies to the tides (nondimensional) @@ -352,7 +352,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (US%R_to_kg_m3*CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -372,7 +372,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & + (US%R_to_kg_m3*CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -398,7 +398,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc delta_sst = data_restore(i,j)- sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & - (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + (US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 enddo ; enddo endif @@ -836,7 +836,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (CS%allow_flux_adjustments) then ! Apply adjustments to forces - call apply_force_adjustments(G, CS, Time, forces) + call apply_force_adjustments(G, US, CS, Time, forces) endif !### ! Allow for user-written code to alter fluxes after all the above @@ -881,9 +881,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real, dimension(SZIB_(G),SZJB_(G)) :: tauy_in_B ! Meridional wind stresses [R Z L T-2 ~> Pa] at q points real :: gustiness ! unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] - real :: Irho0 ! Inverse of the mean density rescaled to [Z2 s2 m T-2 kg-1 ~> m3 kg-1] + real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] real :: taux2, tauy2 ! squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] logical :: do_ustar, do_gustless @@ -896,8 +897,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, Isqh = G%IscB-halo ; Ieqh = G%IecB+halo ; Jsqh = G%JscB-halo ; Jeqh = G%JecB+halo i0 = is - index_bounds(1) ; j0 = js - index_bounds(3) - Irho0 = (US%m_to_Z*US%T_to_s)**2 / CS%Rho0 - stress_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * CS%wind_stress_multiplier + IRho0 = US%L_to_Z / CS%Rho0 + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + stress_conversion = Pa_conversion * CS%wind_stress_multiplier + !### Pa_conversion*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L = 1.0 do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) @@ -1008,15 +1011,15 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & gustiness = CS%gust(i,j) endif - ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*IOB%stress_mag(i-i0,j-j0)) + ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_conversion*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif if (CS%answers_2018) then if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(IOB%stress_mag(i-i0,j-j0) / CS%Rho0) + gustless_ustar(i,j) = sqrt(Pa_conversion*US%L_to_Z*IOB%stress_mag(i-i0,j-j0) / CS%Rho0) enddo ; enddo ; endif else if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(Irho0 * IOB%stress_mag(i-i0,j-j0)) + gustless_ustar(i,j) = sqrt(IRho0 * Pa_conversion*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif endif elseif (wind_stagger == BGRID_NE) then @@ -1031,11 +1034,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) + if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z*tau_mag / CS%Rho0) + if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif enddo ; enddo elseif (wind_stagger == AGRID) then @@ -1043,11 +1046,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) + if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z*tau_mag / CS%Rho0) + if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif enddo ; enddo else ! C-grid wind stresses. @@ -1064,11 +1067,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust_const if (CS%read_gust_2d) gustiness = CS%gust(i,j) - if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) + if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z*tau_mag / CS%Rho0) + if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else - if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*tau_mag) + if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif enddo ; enddo endif ! endif for wind friction velocity fields @@ -1127,8 +1130,9 @@ end subroutine apply_flux_adjustments !! Available adjustments are: !! - taux_adj (Zonal wind stress delta, positive to the east [Pa]) !! - tauy_adj (Meridional wind stress delta, positive to the north [Pa]) -subroutine apply_force_adjustments(G, CS, Time, forces) +subroutine apply_force_adjustments(G, US, CS, Time, forces) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces @@ -1139,12 +1143,11 @@ subroutine apply_force_adjustments(G, CS, Time, forces) integer :: isc, iec, jsc, jec, i, j real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] logical :: overrode_x, overrode_y - type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type - - US => G%US isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged @@ -1165,8 +1168,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempx_at_h(i,j) - merid_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempy_at_h(i,j) + zonal_tau = Pa_conversion * tempx_at_h(i,j) + merid_tau = Pa_conversion * tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo @@ -1259,7 +1262,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & @@ -1437,13 +1440,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied utide=CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif @@ -1455,8 +1458,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& @@ -1464,7 +1467,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1) ! units should be Pa + call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index b6c48ca52c..24f2419692 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -97,13 +97,13 @@ module MOM_surface_forcing real :: south_lat ! southern latitude of the domain real :: len_lat ! domain length in latitude - real :: Rho0 ! Boussinesq reference density [kg m-3] + real :: Rho0 ! Boussinesq reference density [R ~> kg m-3] real :: G_Earth ! gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const ! piston velocity for surface restoring [m s-1] - real :: gust_const ! constant unresolved background gustiness for ustar [Pa] + real :: gust_const ! constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] logical :: read_gust_2d ! if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() ! spatially varying unresolved background gustiness [Pa] + real, pointer :: gust(:,:) => NULL() ! spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] ! gust is used when read_gust_2d is true. real, pointer :: T_Restore(:,:) => NULL() ! temperature to damp (restore) the SST to [degC] @@ -270,7 +270,7 @@ subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, U ! Fields that exist in both the forcing and mech_forcing types must be copied. if (CS%variable_winds .or. CS%first_call_set_forcing) then call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) + call set_derived_forcing_fields(forces, fluxes, G, US, (US%R_to_kg_m3*CS%Rho0)) endif if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & @@ -352,11 +352,11 @@ subroutine wind_forcing_zero(sfc_state, forces, day, G, US, CS) if (CS%read_gust_2d) then if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)/CS%Rho0) + forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust(i,j)/CS%Rho0) enddo ; enddo ; endif else if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const/CS%Rho0) + forces%ustar(i,j) = sqrt(US%L_to_Z*CS%gust_const/CS%Rho0) enddo ; enddo ; endif endif @@ -476,9 +476,9 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) ! set the friction velocity do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & - forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & - forces%taux(i,j)*forces%taux(i,j)))* US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L /CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%ustar(i,j) = sqrt(US%L_to_S * (CS%gust_const/CS%Rho0 + & + sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + forces%tauy(i,j)*forces%tauy(i,j) + & + forces%taux(i-1,j)*forces%taux(i-1,j) + forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0) ) enddo ; enddo call callTree_leave("wind_forcing_gyres") @@ -503,6 +503,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) character(len=200) :: filename ! The name of the input file. real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. + real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress + ! units [R Z L T-2 Pa-1 ~> 1] integer :: days, seconds call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") @@ -511,6 +513,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) 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 + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z call get_time(day,seconds,days) time_lev = days - 365*floor(real(days) / 365.0) +1 @@ -525,34 +528,32 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev) + timelevel=time_lev, scale=Pa_conversion) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.5 * CS%wind_scale * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (temp_x(i,j) + temp_x(i+1,j)) + forces%taux(I,j) = 0.5 * CS%wind_scale * (temp_x(i,j) + temp_x(i+1,j)) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.5 * CS%wind_scale * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (temp_y(i,j) + temp_y(i,j+1)) + forces%tauy(i,J) = 0.5 * CS%wind_scale * (temp_y(i,j) + temp_y(i,j+1)) enddo ; enddo if (CS%read_gust_2d) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) + forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust(i,j) + & + sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) ) / CS%Rho0) enddo ; enddo else do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & + sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) enddo ; enddo endif case ("C") call MOM_read_vector(filename,CS%stress_x_var, CS%stress_y_var, & forces%taux(:,:), forces%tauy(:,:), & G%Domain, timelevel=time_lev, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + scale=Pa_conversion) if (CS%wind_scale /= 1.0) then do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = CS%wind_scale * forces%taux(I,j) @@ -565,15 +566,15 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) if (CS%read_gust_2d) then do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L * & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & - forces%taux(i,j)**2))) + CS%gust(i,j)) / CS%Rho0 ) + forces%ustar(i,j) = sqrt( (CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2)))) * US%L_to_Z / CS%Rho0 ) enddo ; enddo else do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) * & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & + sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) / CS%Rho0) ) enddo ; enddo endif case default @@ -628,7 +629,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) call buoyancy_forcing_allocate(fluxes, G, CS) if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/CS%Rho0 + Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) ! Read the file containing the buoyancy forcing. call get_time(day,seconds,days) @@ -744,7 +745,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + fluxes%vprec(i,j) = - ((US%R_to_kg_m3*CS%Rho0)*CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -756,7 +757,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) else fluxes%buoy(i,j) = 0.0 endif @@ -876,8 +877,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + ((T_Restore - sfc_state%SST(i,j)) * (((US%R_to_kg_m3*CS%Rho0) * fluxes%C_p) * CS%Flux_const)) + fluxes%vprec(i,j) = - ((US%R_to_kg_m3*CS%Rho0)*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else @@ -891,7 +892,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1079,7 +1080,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& @@ -1116,8 +1117,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) @@ -1127,8 +1128,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) ; CS%gust(:,:) = 0.0 filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, & - timelevel=1) ! units should be Pa + call MOM_read_data(filename,'gustiness',CS%gust,G%domain, timelevel=1, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 86bc54e6e1..1eeb71c44c 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -63,7 +63,7 @@ module MOM_surface_forcing_mct logical :: use_temperature !! If true, temp and saln used as state variables real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). - real :: Rho0 !< Boussinesq reference density [kg m-3] + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: area_surf = -1.0 !< total ocean surface area [m2] real :: latent_heat_fusion !< latent heat of fusion [J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] @@ -78,14 +78,14 @@ module MOM_surface_forcing_mct !! the correction for the atmospheric (and sea-ice) !! pressure limited by max_p_surf instead of the !! full atmospheric pressure. The default is true. - real :: gust_const !< constant unresolved background gustiness for ustar [Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the !! bottom boundary layer by drag on the tidal flows [W m-2] gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar [Pa]. + !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. !! gust is used when read_gust_2d is true. ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [m/s] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) @@ -355,7 +355,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (US%R_to_kg_m3*CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 enddo; enddo if (CS%adjust_net_srestore_to_zero) then @@ -375,7 +375,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & + (US%R_to_kg_m3*CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo; enddo @@ -401,7 +401,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & delta_sst = data_restore(i,j)- sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & - (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + (US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 enddo; enddo endif @@ -588,18 +588,20 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! local variables real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & !< Zonal wind stresses at q points [Pa] - tauy_at_q !< Meridional wind stresses at q points [Pa] + taux_at_q, & !< Zonal wind stresses at q points [R Z L T-2 ~> Pa] + tauy_at_q !< Meridional wind stresses at q points [R Z L T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G)) :: & rigidity_at_h, & !< Ice rigidity at tracer points [m3 s-1] - taux_at_h, & !< Zonal wind stresses at h points [Pa] - tauy_at_h !< Meridional wind stresses at h points [Pa] - - real :: gustiness !< unresolved gustiness that contributes to ustar [Pa] - real :: Irho0 !< inverse of the mean density in [m3 kg-1] - real :: taux2, tauy2 !< squared wind stresses [Pa2] - real :: tau_mag !< magnitude of the wind stress [Pa] + taux_at_h, & !< Zonal wind stresses at h points [R Z L T-2 ~> Pa] + tauy_at_h !< Meridional wind stresses at h points [R Z L T-2 ~> Pa] + + real :: gustiness !< unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] + real :: Irho0 !< inverse of the mean density in [Z L-1 R-1 ~> m3 kg-1] + real :: taux2, tauy2 !< squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] + real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] + real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] real :: I_GEarth !< 1.0 / G%G_Earth [s2 m-1] real :: Kv_rho_ice !< (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] real :: mass_ice !< mass of sea ice at a face [kg m-2] @@ -622,7 +624,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) !i0 = is - isc_bnd ; j0 = js - jsc_bnd i0 = 0; j0 = 0 - Irho0 = 1.0/CS%Rho0 + Irho0 = US%L_to_Z / CS%Rho0 + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + stress_conversion = Pa_conversion * CS%wind_stress_multiplier ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. @@ -704,16 +708,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) if (wind_stagger == BGRID_NE) then - if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion elseif (wind_stagger == AGRID) then - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * stress_conversion else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * & - US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z*CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * & - US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z*CS%wind_stress_multiplier + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion endif enddo ; enddo @@ -727,8 +729,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dBu(I,J)*taux_at_q(I,J) + & + forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo; enddo @@ -736,8 +737,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dBu(I,J)*tauy_at_q(I,J) + & + forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo; enddo @@ -757,7 +757,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0*tau_mag) + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo; enddo elseif (wind_stagger == AGRID) then @@ -766,8 +766,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dT(i,j)*taux_at_h(i,j) + & + forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo; enddo @@ -775,8 +774,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dT(i,j)*tauy_at_h(i,j) + & + forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo; enddo @@ -784,7 +782,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo; enddo @@ -805,11 +803,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + & - Irho0*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + & - Irho0*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo; enddo @@ -854,7 +850,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%allow_flux_adjustments) then ! Apply adjustments to forces - call apply_force_adjustments(G, CS, Time, forces) + call apply_force_adjustments(G, US, CS, Time, forces) endif !### ! Allow for user-written code to alter fluxes after all the above @@ -914,8 +910,9 @@ end subroutine apply_flux_adjustments !! Available adjustments are: !! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) !! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_force_adjustments(G, CS, Time, forces) +subroutine apply_force_adjustments(G, US, CS, Time, forces) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces @@ -926,9 +923,11 @@ subroutine apply_force_adjustments(G, CS, Time, forces) integer :: isc, iec, jsc, jec, i, j real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] logical :: overrode_x, overrode_y isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged @@ -949,8 +948,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempx_at_h(i,j) - merid_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempy_at_h(i,j) + zonal_tau = Pa_conversion * tempx_at_h(i,j) + merid_tau = Pa_conversion * tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo @@ -1046,7 +1045,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & @@ -1211,13 +1210,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied utide=CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif @@ -1240,7 +1239,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1) ! units should be Pa + call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif ! See whether sufficiently thick sea ice should be treated as rigid. diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index bd4ff4e0e8..96645f10d2 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -64,7 +64,7 @@ module MOM_surface_forcing_nuopc logical :: use_temperature !! If true, temp and saln used as state variables real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress (nondim). - real :: Rho0 !< Boussinesq reference density [kg/m^3] + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: area_surf = -1.0 !< total ocean surface area [m^2] real :: latent_heat_fusion !< latent heat of fusion [J/kg] real :: latent_heat_vapor !< latent heat of vaporization [J/kg] @@ -80,14 +80,14 @@ module MOM_surface_forcing_nuopc !! pressure limited by max_p_surf instead of the !! full atmospheric pressure. The default is true. - real :: gust_const !< constant unresolved background gustiness for ustar [Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the !! bottom boundary layer by drag on the tidal flows [W m-2] gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar [Pa]. + !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. !! gust is used when read_gust_2d is true. ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) @@ -361,7 +361,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (US%R_to_kg_m3*CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -381,7 +381,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & + (US%R_to_kg_m3*CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -407,7 +407,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & delta_sst = data_restore(i,j)- sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & - (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + (US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 enddo ; enddo endif @@ -590,10 +590,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) taux_at_h, & !< Zonal wind stresses at h points [Pa] tauy_at_h !< Meridional wind stresses at h points [Pa] - real :: gustiness !< unresolved gustiness that contributes to ustar [Pa] - real :: Irho0 !< inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 !< squared wind stresses (Pa^2) - real :: tau_mag !< magnitude of the wind stress [Pa] + real :: gustiness !< unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] + real :: Irho0 !< inverse of the mean density in [Z L-1 R-1 ~> m3 kg-1] + real :: taux2, tauy2 !< squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] + real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] + real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] real :: I_GEarth !< 1.0 / G_Earth [s2 m-1] real :: Kv_rho_ice !< (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) real :: mass_ice !< mass of sea ice at a face (kg/m^2) @@ -615,7 +617,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 i0 = is - isc_bnd ; j0 = js - jsc_bnd - Irho0 = 1.0/CS%Rho0 + Irho0 = US%L_to_Z / CS%Rho0 + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + stress_conversion = Pa_conversion * CS%wind_stress_multiplier ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. @@ -701,16 +705,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) if (wind_stagger == BGRID_NE) then - if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion elseif (wind_stagger == AGRID) then - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * stress_conversion else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * & - US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * & - US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * CS%wind_stress_multiplier + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * stress_conversion + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * stress_conversion endif enddo ; enddo @@ -724,8 +726,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dBu(I,J)*taux_at_q(I,J) + & + forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo @@ -733,8 +734,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dBu(I,J)*tauy_at_q(I,J) + & + forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo @@ -754,7 +754,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0*tau_mag) + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo ; enddo elseif (wind_stagger == AGRID) then @@ -763,8 +763,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dT(i,j)*taux_at_h(i,j) + & + forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo @@ -772,8 +771,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (G%mask2dT(i,j)*tauy_at_h(i,j) + & + forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo @@ -781,7 +779,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo ; enddo @@ -802,11 +800,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust(i,j)*Irho0 + & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*Irho0*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(CS%gust_const*Irho0 + & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*Irho0*sqrt(taux2 + tauy2)) + forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo @@ -851,7 +847,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%allow_flux_adjustments) then ! Apply adjustments to forces - call apply_force_adjustments(G, CS, Time, forces) + call apply_force_adjustments(G, US, CS, Time, forces) endif !### ! Allow for user-written code to alter fluxes after all the above @@ -910,8 +906,9 @@ end subroutine apply_flux_adjustments !! Available adjustments are: !! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) !! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_force_adjustments(G, CS, Time, forces) +subroutine apply_force_adjustments(G, US, CS, Time, forces) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces @@ -922,9 +919,11 @@ subroutine apply_force_adjustments(G, CS, Time, forces) integer :: isc, iec, jsc, jec, i, j real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] logical :: overrode_x, overrode_y isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged @@ -945,8 +944,8 @@ subroutine apply_force_adjustments(G, CS, Time, forces) if (rDlon > 0.) rDlon = 1. / rDlon cosA = dLonDx * rDlon sinA = dLonDy * rDlon - zonal_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempx_at_h(i,j) - merid_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * tempy_at_h(i,j) + zonal_tau = Pa_conversion * tempx_at_h(i,j) + merid_tau = Pa_conversion * tempy_at_h(i,j) tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau enddo ; enddo @@ -1042,7 +1041,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & @@ -1207,13 +1206,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied utide=CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif @@ -1227,8 +1226,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& @@ -1236,7 +1235,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1) ! units should be Pa + call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif ! See whether sufficiently thick sea ice should be treated as rigid. diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 19995caab7..101956d283 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -78,7 +78,7 @@ module MOM_surface_forcing real :: south_lat !< southern latitude of the domain real :: len_lat !< domain length in latitude - real :: Rho0 !< Boussinesq reference density [kg m-3] + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const !< piston velocity for surface restoring [m s-1] real :: Flux_const_T !< piston velocity for surface temperature restoring [m s-1] @@ -88,9 +88,9 @@ module MOM_surface_forcing real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" forcing real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" forcing - real :: gust_const !< constant unresolved background gustiness for ustar [Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [Pa] + real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] !! gust is used when read_gust_2d is true. real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] @@ -309,7 +309,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US elseif (trim(CS%buoy_config) == "const") then call buoyancy_forcing_const(sfc_state, fluxes, day_center, dt, G, CS) elseif (trim(CS%buoy_config) == "linear") then - call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, CS) + call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "MESO") then call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%MESO_forcing_CSp) elseif (trim(CS%buoy_config) == "Neverland") then @@ -371,32 +371,34 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by !! a previous surface_forcing_init call ! Local variables + real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] real :: mag_tau integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq call callTree_enter("wind_forcing_const, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z !set steady surface wind stresses, in units of Pa. !### mag_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * sqrt( tau_x0**2 + tau_y0**2) - mag_tau = sqrt( tau_x0**2 + tau_y0**2) + mag_tau = Pa_conversion * sqrt( tau_x0**2 + tau_y0**2) do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = tau_x0 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + forces%taux(I,j) = tau_x0 * Pa_conversion enddo ; enddo do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = tau_y0 * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + forces%tauy(i,J) = tau_y0 * Pa_conversion enddo ; enddo if (CS%read_gust_2d) then if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) + forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) enddo ; enddo ; endif else if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( ( mag_tau + CS%gust_const ) / CS%Rho0 ) + forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust_const ) / CS%Rho0 ) enddo ; enddo ; endif endif @@ -507,18 +509,16 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) ! set the friction velocity if (CS%answers_2018) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & - forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & - forces%taux(i,j)*forces%taux(i,j))) * & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%ustar(i,j) = sqrt(US%L_to_Z * ((CS%gust_const/CS%Rho0) + & + sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + forces%tauy(i,j)*forces%tauy(i,j) + & + forces%taux(i-1,j)*forces%taux(i-1,j) + forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0) ) enddo ; enddo else - I_rho = 1.0 / CS%Rho0 + I_rho = US%L_to_Z / CS%Rho0 do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt( (CS%gust_const + & + forces%ustar(i,j) = sqrt( (CS%gust_const + & sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) * & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L ) * I_rho ) + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) enddo ; enddo endif @@ -539,7 +539,10 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) ! Local variables character(len=200) :: filename ! The name of the input file. real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. + real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [R L Z T-1 ~> Pa]. + real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress + ! units [R Z L T-2 Pa-1 ~> 1] + real :: Rho0_mks ! The mean density in MKS units [kg m-3] integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and montly cycles. integer :: time_lev ! The time level that is used for a field. @@ -550,6 +553,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + Rho0_mks = CS%Rho0 * US%R_to_kg_m3 call get_time(day, seconds, days) time_lev_daily = days - 365*floor(real(days) / 365.0) @@ -587,9 +592,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) case ("A") temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & - temp_x(:,:), temp_y(:,:), & - G%Domain, stagger=AGRID, timelevel=time_lev, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & + timelevel=time_lev, scale=Pa_conversion) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=js,je ; do I=is-1,Ieq @@ -602,13 +606,13 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L + CS%gust(i,j)) / CS%Rho0) + forces%ustar(i,j) = sqrt((CS%gust(i,j) + & + sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j))) * US%L_to_Z / CS%Rho0) enddo ; enddo else do j=js,je ; do i=is,ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) * US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & + sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) enddo ; enddo endif endif @@ -623,7 +627,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), & G%Domain_aux, stagger=CGRID_NE, timelevel=time_lev, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + scale=Pa_conversion) do j=js,je ; do i=is,ie forces%taux(I,j) = CS%wind_scale * temp_x(I,j) forces%tauy(i,J) = CS%wind_scale * temp_y(i,J) @@ -633,7 +637,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & forces%taux(:,:), forces%tauy(:,:), & G%Domain, stagger=CGRID_NE, timelevel=time_lev, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + scale=Pa_conversion) if (CS%wind_scale /= 1.0) then do j=js,je ; do I=Isq,Ieq @@ -649,15 +653,15 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) * & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L + CS%gust(i,j)) / CS%Rho0 ) + forces%ustar(i,j) = sqrt((CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) ) * US%L_to_Z / CS%Rho0 ) enddo ; enddo else do j=js, je ; do i=is, ie - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & - forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) * & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%ustar(i,j) = sqrt(US%L_to_Z * ( (CS%gust_const/CS%Rho0) + & + sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & + (forces%taux(i-1,j)**2 + forces%taux(i,j)**2)))/CS%Rho0)) enddo ; enddo endif endif @@ -693,6 +697,7 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. real :: temp_ustar(SZI_(G),SZJ_(G)) ! ustar [m s-1] (not rescaled). + real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] integer :: i, j, is_in, ie_in, js_in, je_in logical :: read_uStar @@ -704,10 +709,9 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) CS%dataOverrideIsInitialized = .True. endif - is_in = G%isc - G%isd + 1 - ie_in = G%iec - G%isd + 1 - js_in = G%jsc - G%jsd + 1 - je_in = G%jec - G%jsd + 1 + is_in = G%isc - G%isd + 1 ; ie_in = G%iec - G%isd + 1 + js_in = G%jsc - G%jsd + 1 ; je_in = G%jec - G%jsd + 1 + Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call data_override('OCN', 'taux', temp_x, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -715,10 +719,10 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) ! Ignore CS%wind_scale when using data_override ????? do j=G%jsc,G%jec ; do I=G%isc-1,G%IecB - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * 0.5 * (temp_x(i,j) + temp_x(i+1,j)) + forces%taux(I,j) = Pa_conversion * 0.5 * (temp_x(i,j) + temp_x(i+1,j)) enddo ; enddo do J=G%jsc-1,G%JecB ; do i=G%isc,G%iec - forces%tauy(i,J) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * 0.5 * (temp_y(i,j) + temp_y(i,j+1)) + forces%tauy(i,J) = Pa_conversion * 0.5 * (temp_y(i,j) + temp_y(i,j+1)) enddo ; enddo read_Ustar = (len_trim(CS%ustar_var) > 0) ! Need better control higher up ???? @@ -730,13 +734,13 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) if (CS%read_gust_2d) then call data_override('OCN', 'gust', CS%gust, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) + forces%ustar(i,j) = sqrt((Pa_conversion * sqrt(temp_x(i,j)*temp_x(i,j) + & + temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) * US%L_to_Z / CS%Rho0) enddo ; enddo else do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & - temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) + forces%ustar(i,j) = sqrt(US%L_to_Z * (Pa_conversion*sqrt(temp_x(i,j)*temp_x(i,j) + & + temp_y(i,j)*temp_y(i,j))/CS%Rho0 + CS%gust_const/CS%Rho0 )) enddo ; enddo endif endif @@ -785,8 +789,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/CS%Rho0 + if (CS%use_temperature) rhoXcp = US%R_to_kg_m3*CS%Rho0 * fluxes%C_p + Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) ! Read the buoyancy forcing file call get_time(day, seconds, days) @@ -987,7 +991,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (US%R_to_kg_m3*CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -999,7 +1003,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) else fluxes%buoy(i,j) = 0.0 endif @@ -1050,7 +1054,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! anomalies when calculating restorative precipitation ! anomalies [ppt]. real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. - real :: Irho0 ! The inverse of the Boussinesq density [m3 kg-1]. + real :: Rho0_mks ! The mean density in MKS units [kg m-3] integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and montly cycles. @@ -1064,9 +1068,9 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + Rho0_mks = CS%Rho0 * US%R_to_kg_m3 if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/CS%Rho0 if (.not.CS%dataOverrideIsInitialized) then call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) @@ -1132,7 +1136,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (Rho0_mks*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1144,7 +1148,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/Rho0_mks) else fluxes%buoy(i,j) = 0.0 endif @@ -1280,7 +1284,7 @@ end subroutine buoyancy_forcing_const !> Sets surface fluxes of heat and salinity by restoring to temperature and !! salinity profiles that vary linearly with latitude. -subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) +subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields @@ -1288,14 +1292,17 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) real, intent(in) :: dt !< The amount of time over which !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by !! a previous surface_forcing_init call ! Local variables + real :: Rho0_mks ! The mean density in MKS units [kg m-3] real :: y, T_restore, S_restore integer :: i, j, is, ie, js, je call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Rho0_mks = CS%Rho0 * US%R_to_kg_m3 ! This case has no surface buoyancy forcing. if (CS%use_temperature) then @@ -1328,8 +1335,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + ((T_Restore - sfc_state%SST(i,j)) * ((Rho0_mks * fluxes%C_p) * CS%Flux_const)) + fluxes%vprec(i,j) = - (Rho0_mks*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else @@ -1343,7 +1350,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/CS%Rho0) + ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/Rho0_mks) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1648,7 +1655,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& @@ -1706,8 +1713,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) @@ -1717,8 +1724,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, & - timelevel=1) ! units should be Pa + call MOM_read_data(filename,'gustiness',CS%gust,G%domain, timelevel=1, & + scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif ! All parameter settings are now known. @@ -1735,7 +1742,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS%Neverland_forcing_CSp) elseif (trim(CS%wind_config) == "ideal_hurr" .or.& trim(CS%wind_config) == "SCM_ideal_hurr") then - call idealized_hurricane_wind_init(Time, G, param_file, CS%idealized_hurricane_CSp) + call idealized_hurricane_wind_init(Time, G, US, param_file, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "const") then call get_param(param_file, mdl, "CONST_WIND_TAUX", CS%tau_x0, & "With wind_config const, this is the constant zonal "//& @@ -1746,7 +1753,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C elseif (trim(CS%wind_config) == "SCM_CVmix_tests" .or. & trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_surface_forcing_init(Time, G, param_file, CS%SCM_CVmix_tests_CSp) - CS%SCM_CVmix_tests_CSp%Rho0 = CS%Rho0 !copy reference density for pass + CS%SCM_CVmix_tests_CSp%Rho0 = US%R_to_kg_m3*CS%Rho0 !copy reference density for pass endif call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index d8cf2ccddc..d1fe150767 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -105,9 +105,10 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) ! is always positive. ! if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! ! This expression can be changed if desired, but need not be. -! forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & -! US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & -! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) +! forces%ustar(i,j) = G%mask2dT(i,j) * sqrt((CS%gust_const + & +! sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & +! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * & +! (US%L_to_Z * US%R_to_kg_m3/CS%Rho0) ) ! enddo ; enddo ; endif end subroutine Neverland_wind_forcing diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 8660d59256..1afe999e51 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -33,11 +33,11 @@ module user_surface_forcing 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 [kg m-3]. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 s-2 ~> m s-2]. real :: Flux_const !< The restoring rate at the surface [m s-1]. real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [Pa]. + !! that contributes to ustar [R L Z T-1 ~> Pa]. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -72,7 +72,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! Allocate the forcing arrays, if necessary. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - ! Set the surface wind stresses, in units of Pa. A positive taux + ! Set the surface wind stresses, in units of [R L Z T-1 ~> Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. ! The i-loop extends to is-1 so that taux can be used later in the @@ -85,13 +85,13 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. enddo ; enddo - ! Set the surface friction velocity, in units of m s-1. ustar + ! Set the surface friction velocity, in units of [Z T-1 ~> m s-1]. ustar ! is always positive. if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt((CS%gust_const + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * (US%L_to_Z/CS%Rho0)) enddo ; enddo ; endif end subroutine USER_wind_forcing @@ -131,6 +131,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real :: density_restore ! The potential density that is being restored ! toward [kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + real :: Rho0_mks ! The mean density in MKS units [kg m-3] real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. @@ -139,6 +140,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + Rho0_mks = CS%Rho0 * US%R_to_kg_m3 ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. @@ -200,7 +202,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = Rho0_mks * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in PSU or ppt) that are being restored toward. @@ -209,7 +211,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (Rho0_mks*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / & (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo @@ -220,7 +222,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / Rho0_mks do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. @@ -270,10 +272,10 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 18b21eef3e..b4cbb32401 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -52,8 +52,8 @@ module Idealized_hurricane real :: max_windspeed !< Maximum wind speeds [m s-1] real :: hurr_translation_spd !< Hurricane translation speed [m s-1] real :: hurr_translation_dir !< Hurricane translation speed [m s-1] - real :: gustiness !< Gustiness (optional, used in u*) [m s-1] - real :: Rho0 !< A reference ocean density [kg m-3] + real :: gustiness !< Gustiness (optional, used in u*) [R L Z T-1 ~> Pa] + real :: Rho0 !< A reference ocean density [R ~> kg m-3] real :: Hurr_cen_Y0 !< The initial y position of the hurricane !! This experiment is conducted in a Cartesian !! grid and this is assumed to be in meters [m] @@ -90,15 +90,12 @@ module Idealized_hurricane contains !> Initializes wind profile for the SCM idealized hurricane example -subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) - type(time_type), & - intent(in) :: Time !< Model time - type(ocean_grid_type), & - intent(in) :: G !< Grid structure - type(param_file_type), & - intent(in) :: param_file !< Input parameter structure - type(idealized_hurricane_CS), & - pointer :: CS !< Parameter container +subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) + type(time_type), intent(in) :: Time !< Model time + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(idealized_hurricane_CS), pointer :: CS !< Parameter container for this module real :: DP, C @@ -178,10 +175,10 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, do_not_log=.true.) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, & "The background gustiness in the winds.", units="Pa", & - default=0.00, do_not_log=.true.) + default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, do_not_log=.true.) if (CS%BR_BENCH) then @@ -193,7 +190,6 @@ subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) CS%Holland_A = (CS%rad_max_wind)**CS%Holland_B CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*DP - return end subroutine idealized_hurricane_wind_init !> Computes the surface wind for the idealized hurricane test cases @@ -299,10 +295,9 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) do j=js,je do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gustiness/CS%Rho0 + & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L * & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gustiness/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) enddo enddo @@ -603,10 +598,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) ! Set the surface friction velocity [m s-1]. ustar is always positive. do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gustiness/CS%Rho0 + & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L * & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gustiness/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) enddo ; enddo end subroutine SCM_idealized_hurricane_wind_forcing diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 8c2d3359e6..a61600fa56 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -219,10 +219,9 @@ subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) - mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( US%R_to_kg_m3*US%L_to_Z * mag_tau / CS%Rho0 ) + forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / (US%kg_m3_to_R*CS%Rho0) ) enddo ; enddo ; endif end subroutine SCM_CVMix_tests_wind_forcing From fb47d7b6dc033fd95328499a5d0eb4a7dda29dc4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Oct 2019 18:47:26 -0400 Subject: [PATCH 144/259] +Changed set_derived_forcing_fields Rho0 arg units Changed the units of the Rho0 argument passed to set_derived_forcing_fields to [R]. All answers are bitwise identical, but the units of an argument in a public interface have changed. --- config_src/ice_solo_driver/MOM_surface_forcing.F90 | 2 +- config_src/mct_driver/mom_ocean_model_mct.F90 | 2 +- config_src/nuopc_driver/mom_ocean_model_nuopc.F90 | 2 +- src/core/MOM_forcing_type.F90 | 10 ++++------ 4 files changed, 7 insertions(+), 9 deletions(-) diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 24f2419692..f86fc44101 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -270,7 +270,7 @@ subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, U ! Fields that exist in both the forcing and mech_forcing types must be copied. if (CS%variable_winds .or. CS%first_call_set_forcing) then call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, US, (US%R_to_kg_m3*CS%Rho0)) + call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) endif if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 8873f283ff..4f1c7d963a 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -582,7 +582,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & #endif endif - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%US%R_to_kg_m3*OS%GV%Rho0) + call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%use_waves) then diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index db475754c9..e04064f672 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -570,7 +570,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average #endif endif - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%US%R_to_kg_m3*OS%GV%Rho0) + call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%use_waves) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a51219bb1f..e34c4f243d 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2052,8 +2052,6 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) end subroutine copy_common_forcing_fields -!### Change the units of Rho0 passed to set_derived_forcing_fields. - !> This subroutine calculates certain derived forcing fields based on information !! from a mech_forcing type and stores them in a (thermodynamic) forcing type. subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) @@ -2061,7 +2059,7 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(ocean_grid_type), intent(in) :: G !< grid type type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: Rho0 !< A reference density of seawater [kg m-3], + real, intent(in) :: Rho0 !< A reference density of seawater [R ~> kg m-3], !! as used to calculate ustar. real :: taux2, tauy2 ! Squared wind stress components [R2 L2 Z2 T-4 ~> Pa2]. @@ -2069,7 +2067,7 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Irho0 = US%L_to_Z / (US%kg_m3_to_R*Rho0) + Irho0 = US%L_to_Z / Rho0 if (associated(forces%taux) .and. associated(forces%tauy) .and. & associated(fluxes%ustar_gustless)) then @@ -2085,8 +2083,8 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - fluxes%ustar_gustless(i,j) = sqrt(US%R_to_kg_m3*US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) -!### Change to: + fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) +!### For efficiency this could be changed to: ! fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) enddo ; enddo endif From 86216c67de2d18dc883a3c9c6977288ce79a5d84 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 5 Sep 2019 07:53:57 -0800 Subject: [PATCH 145/259] Fixing up restart of tracer reservoirs. - Still funkiness - rx_normal restarts aren't working either --- src/core/MOM.F90 | 10 +- src/core/MOM_open_boundary.F90 | 262 +++++++++++++++++++++++++++---- src/tracer/DOME_tracer.F90 | 2 +- src/user/DOME_initialization.F90 | 14 +- 4 files changed, 252 insertions(+), 36 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a08149aab2..f90a614fda 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2123,7 +2123,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%mixedlayer_restrat_CSp, restart_CSp) if (associated(CS%OBC)) & - call open_boundary_register_restarts(dg%HI, GV, CS%OBC, restart_CSp) + call open_boundary_register_restarts(dg%HI, GV, CS%OBC, CS%tracer_Reg, & + param_file, restart_CSp, use_temperature) call callTree_waypoint("restart registration complete (initialize_MOM)") @@ -2162,6 +2163,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") +! ! Need this after MOM_initialize_state for DOME OBC stuff. +! if (associated(CS%OBC)) & +! call open_boundary_register_restarts(G%HI, GV, CS%OBC, CS%tracer_Reg, & +! param_file, restart_CSp, use_temperature) + +! call callTree_waypoint("restart registration complete (initialize_MOM)") + ! From this point, there may be pointers being set, so the final grid type ! that will persist throughout the run has to be used. diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 680a25cae0..701416cf37 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -80,11 +80,6 @@ module MOM_open_boundary real :: value !< constant value if fid is equal to -1 end type OBC_segment_data_type -!> Tracer segment data structure, for putting into an array of objects, not all the same shape. -!type, public :: segment_tracer_type -! real, dimension(:,:,:), pointer :: tr => NULL() !< tracer concentration array -!end type segment_tracer_type - !> Tracer on OBC segment data structure, for putting into a segment tracer registry. type, public :: OBC_segment_tracer_type real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array @@ -133,8 +128,9 @@ module MOM_open_boundary logical :: z_values_needed!< Whether or not external zeta OBC fields are needed. logical :: g_values_needed!< Whether or not external gradient OBC fields are needed. integer :: direction !< Boundary faces one of the four directions. - logical :: is_N_or_S !< True is the OB is facing North or South and exists on this PE. - logical :: is_E_or_W !< True is the OB is facing East or West and exists on this PE. + logical :: is_N_or_S !< True if the OB is facing North or South and exists on this PE. + logical :: is_E_or_W !< True if the OB is facing East or West and exists on this PE. + logical :: is_E_or_W_2 !< True if the OB is facing East or West anywhere. type(OBC_segment_data_type), pointer, dimension(:) :: field=>NULL() !< OBC data integer :: num_fields !< number of OBC data fields (e.g. u_normal,u_parallel and eta for Flather) character(len=32), pointer, dimension(:) :: field_names=>NULL() !< field names for this segment @@ -234,6 +230,13 @@ module MOM_open_boundary !! use in the biharmonic viscosity term. logical :: brushcutter_mode = .false. !< If True, read data on supergrid. real :: g_Earth !< The gravitational acceleration [m s-2]. + logical, pointer, dimension(:) :: & + tracer_x_reservoirs_used => NULL() !< Dimensioned by the number of tracers, set globally, + !! true for those with x reservoirs (needed for restarts). + logical, pointer, dimension(:) :: & + tracer_y_reservoirs_used => NULL() !< Dimensioned by the number of tracers, set globally, + !! true for those with y reservoirs (needed for restarts). + integer :: ntr = 0 !< number of tracers ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & segment => NULL() !< List of segment objects. @@ -256,6 +259,8 @@ module MOM_open_boundary real, pointer, dimension(:,:,:) :: rx_normal => NULL() !< Array storage for restarts real, pointer, dimension(:,:,:) :: ry_normal => NULL() !< Array storage for restarts real, pointer, dimension(:,:,:) :: cff_normal => NULL() !< Array storage for restarts + real, pointer, dimension(:,:,:,:) :: tres_x => NULL() !< Array storage for restarts + real, pointer, dimension(:,:,:,:) :: tres_y => NULL() !< Array storage for restarts real :: silly_h !< A silly value of thickness outside of the domain that !! can be used to test the independence of the OBCs to !! this external data [H ~> m or kg m-2]. @@ -433,6 +438,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) OBC%segment(l)%direction = OBC_NONE OBC%segment(l)%is_N_or_S = .false. OBC%segment(l)%is_E_or_W = .false. + OBC%segment(l)%is_E_or_W_2 = .false. OBC%segment(l)%Velocity_nudging_timescale_in = 0.0 OBC%segment(l)%Velocity_nudging_timescale_out = 0.0 OBC%segment(l)%num_fields = 0 @@ -533,7 +539,6 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=20) :: segnam, suffix character(len=32) :: varnam, fieldname real :: value - integer :: orient character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list @@ -626,13 +631,6 @@ subroutine initialize_segment_data(G, OBC, PF) endif allocate(segment%field(num_fields)) - -! This should be happening with the x_values_needed. -! if (segment%Flather) then -! if (num_fields < 3) call MOM_error(FATAL, & -! "MOM_open_boundary, initialize_segment_data: "//& -! "Need at least three inputs for Flather") -! endif segment%num_fields = num_fields segment%temp_segment_data_exists=.false. @@ -951,6 +949,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) enddo ! a_loop + OBC%segment(l_seg)%is_E_or_W_2 = .true. + if (I_obc<=G%HI%IsdB+1 .or. I_obc>=G%HI%IedB-1) return ! Boundary is not on tile if (Je_obc<=G%HI%JsdB .or. Js_obc>=G%HI%JedB) return ! Segment is not on tile @@ -1241,7 +1241,7 @@ subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fi logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages ! Local variables character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m, orient + integer :: lword, nfields, n, m logical :: continue,dbg character(len=32), dimension(MAX_OBC_FIELDS) :: flds @@ -1314,6 +1314,71 @@ subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fi end subroutine parse_segment_data_str +!> Parse all the OBC_SEGMENT_%%%_DATA strings again +!! to see which need tracer reservoirs (all pes need to know). + subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure + type(param_file_type), intent(in) :: PF !< Parameter file handle + logical, intent(in) :: use_temperature !< If true, T and S are used + + ! Local variables + integer :: n,m,num_fields + character(len=256) :: segstr, filename + character(len=20) :: segnam, suffix + character(len=32) :: varnam, fieldname + real :: value + character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + character(len=256) :: mesg ! Message for error messages. + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n + write(suffix,"('_segment_',i3.3)") n + ! Clear out any old values + segstr = '' + call get_param(PF, mdl, segnam, segstr) + if (segstr == '') cycle + + call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) + if (num_fields == 0) cycle + + ! At this point, just search for TEMP and SALT as tracers 1 and 2. + 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 + if (fields(m) == 'TEMP') then + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(1) = .true. + else + OBC%tracer_y_reservoirs_used(1) = .true. + endif + endif + if (fields(m) == 'SALT') then + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(2) = .true. + else + OBC%tracer_y_reservoirs_used(2) = .true. + endif + endif + endif + enddo + ! Alternately, set first two to true if use_temperature is true + if (use_temperature) then + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(1) = .true. + OBC%tracer_x_reservoirs_used(2) = .true. + else + OBC%tracer_y_reservoirs_used(1) = .true. + OBC%tracer_y_reservoirs_used(2) = .true. + endif + endif + enddo + + return + +end subroutine parse_for_tracer_reservoirs + !> 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 @@ -1323,7 +1388,7 @@ subroutine parse_segment_param_real(segment_str, var, param_value, debug ) logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages ! Local variables character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m, orient + integer :: lword, nfields, n, m logical :: continue,dbg character(len=32), dimension(MAX_OBC_FIELDS) :: flds @@ -1446,6 +1511,11 @@ subroutine open_boundary_dealloc(OBC) if (associated(OBC%segment)) deallocate(OBC%segment) if (associated(OBC%segnum_u)) deallocate(OBC%segnum_u) if (associated(OBC%segnum_v)) deallocate(OBC%segnum_v) + if (associated(OBC%rx_normal)) deallocate(OBC%rx_normal) + if (associated(OBC%ry_normal)) deallocate(OBC%ry_normal) + if (associated(OBC%cff_normal)) deallocate(OBC%cff_normal) + if (associated(OBC%tres_x)) deallocate(OBC%tres_x) + if (associated(OBC%tres_y)) deallocate(OBC%tres_y) deallocate(OBC) end subroutine open_boundary_dealloc @@ -1610,6 +1680,45 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) end subroutine open_boundary_impose_land_mask +!> Make sure the OBC tracer reservoirs are initialized. +subroutine setup_OBC_tracer_reservoirs(G, OBC) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: i, j, k, m, n + + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (associated(segment%tr_Reg)) then + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do m=1,OBC%ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,G%ke + do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%t(i,j,k) + enddo + enddo + endif + enddo + else + J = segment%HI%JsdB + do m=1,OBC%ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,G%ke + do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%t(i,J,k) + enddo + enddo + endif + enddo + endif + endif + enddo + +end subroutine setup_OBC_tracer_reservoirs + !> Apply radiation conditions to 3D u,v at open boundaries subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure @@ -1637,7 +1746,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) real, pointer, dimension(:,:,:) :: cff_tangential=>NULL() real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2]? type(OBC_segment_type), pointer :: segment => NULL() - integer :: i, j, k, is, ie, js, je, nz, n + integer :: i, j, k, is, ie, js, je, m, nz, n integer :: is_obc, ie_obc, js_obc, je_obc is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -1693,6 +1802,36 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) enddo endif + ! Now tracers (if any) + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (associated(segment%tr_Reg)) then + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do m=1,OBC%ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,G%ke + do j=segment%HI%jsd,segment%HI%jed + segment%tr_Reg%Tr(m)%tres(I,j,k) = OBC%tres_x(I,j,k,m) + enddo + enddo + endif + enddo + else + J = segment%HI%JsdB + do m=1,OBC%ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + do k=1,G%ke + do i=segment%HI%isd,segment%HI%ied + segment%tr_Reg%Tr(m)%tres(i,J,k) = OBC%tres_y(i,J,k,m) + enddo + enddo + endif + enddo + endif + endif + enddo + gamma_u = OBC%gamma_uv ; gamma_v = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments @@ -3961,6 +4100,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:) segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) enddo + call setup_OBC_tracer_reservoirs(G, OBC) end subroutine fill_temp_salt_segments !> Find the region outside of all open boundary segments and @@ -4195,19 +4335,31 @@ 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) +subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart_CSp, & + use_temperature) type(hor_index_type), intent(in) :: HI !< Horizontal indices type(verticalGrid_type), pointer :: GV !< Container for vertical grid information - type(ocean_OBC_type), pointer :: OBC_CS !< OBC data structure, data intent(inout) + type(ocean_OBC_type), pointer :: OBC !< OBC data structure, data intent(inout) + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + type(param_file_type), intent(in) :: param_file !< Parameter file handle type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) + logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables type(vardesc) :: vd + integer :: m, n + character(len=100) :: mesg + type(OBC_segment_type), pointer :: segment=>NULL() - if (.not. associated(OBC_CS)) & + if (.not. associated(OBC)) & call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& "uninitialized OBC control structure") - if (associated(OBC_CS%rx_normal) .or. associated(OBC_CS%ry_normal)) & + if (associated(OBC%rx_normal) .or. associated(OBC%ry_normal) .or. & + associated(OBC%cff_normal)) & + call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& + "arrays were previously allocated") + + if (associated(OBC%tres_x) .or. associated(OBC%tres_y)) & call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& "arrays were previously allocated") @@ -4215,21 +4367,63 @@ subroutine open_boundary_register_restarts(HI, GV, OBC_CS, restart_CSp) ! 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 .or. OBC_CS%oblique_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 + if (OBC%radiation_BCs_exist_globally .or. OBC%oblique_BCs_exist_globally) then + allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) + OBC%rx_normal(:,:,:) = 0.0 vd = var_desc("rx_normal","m s-1", "Normal Phase Speed for EW OBCs",'u','L') - call register_restart_field(OBC_CS%rx_normal, vd, .false., restart_CSp) - allocate(OBC_CS%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) - OBC_CS%ry_normal(:,:,:) = 0.0 + call register_restart_field(OBC%rx_normal, vd, .false., restart_CSp) + allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) + OBC%ry_normal(:,:,:) = 0.0 vd = var_desc("ry_normal","m s-1", "Normal Phase Speed for NS OBCs",'v','L') - call register_restart_field(OBC_CS%ry_normal, vd, .false., restart_CSp) + call register_restart_field(OBC%ry_normal, vd, .false., restart_CSp) endif - if (OBC_CS%oblique_BCs_exist_globally) then - allocate(OBC_CS%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) - OBC_CS%cff_normal(:,:,:) = 0.0 + if (OBC%oblique_BCs_exist_globally) then + allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) + OBC%cff_normal(:,:,:) = 0.0 vd = var_desc("cff_normal","m s-1", "denominator for oblique OBCs",'q','L') - call register_restart_field(OBC_CS%cff_normal, vd, .false., restart_CSp) + call register_restart_field(OBC%cff_normal, vd, .false., restart_CSp) + endif + + if (Reg%ntr == 0) return + if (.not. associated(OBC%tracer_x_reservoirs_used)) then + OBC%ntr = Reg%ntr + allocate(OBC%tracer_x_reservoirs_used(Reg%ntr)) + allocate(OBC%tracer_y_reservoirs_used(Reg%ntr)) + OBC%tracer_x_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(:) = .false. + call parse_for_tracer_reservoirs(OBC, param_file, use_temperature) + else + ! This would be coming from user code such as DOME. + if (OBC%ntr /= Reg%ntr) then +! call MOM_error(FATAL, "open_boundary_regiser_restarts: Inconsistent value for ntr") + write(mesg,'("Inconsisten values for ntr ",'// & + 'I8," and ",I8,".")') OBC%ntr, Reg%ntr + call MOM_error(WARNING, 'open_boundary_register_restarts: '//mesg) + endif + endif + + ! Still painfully inefficient, now in four dimensions. + if (any(OBC%tracer_x_reservoirs_used)) then + allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr)) + OBC%tres_x(:,:,:,:) = 0.0 + do m=1,OBC%ntr + if (OBC%tracer_x_reservoirs_used(m)) then + write(mesg,'("tres_x_",I3.3)') m + vd = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') + call register_restart_field(OBC%tres_x(:,:,:,m), vd, .false., restart_CSp) + endif + enddo + endif + if (any(OBC%tracer_y_reservoirs_used)) then + allocate(OBC%tres_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke,OBC%ntr)) + OBC%tres_y(:,:,:,:) = 0.0 + do m=1,OBC%ntr + if (OBC%tracer_y_reservoirs_used(m)) then + write(mesg,'("tres_y_",I3.3)') m + vd = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') + call register_restart_field(OBC%tres_y(:,:,:,m), vd, .false., restart_CSp) + endif + enddo endif end subroutine open_boundary_register_restarts @@ -4281,6 +4475,7 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) segment%tr_Reg%Tr(m)%tres(I,j,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & dt*(u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) + if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) enddo endif enddo @@ -4305,6 +4500,7 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) segment%tr_Reg%Tr(m)%tres(i,J,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & dt*(v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) + if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) enddo endif enddo diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 7589f04ed0..debfd6f4b1 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, OBC_segment_tracer_type -use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_open_boundary, only : OBC_segment_type use MOM_restart, only : MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 7a2a6bfd90..0a3a5e071f 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -298,10 +298,22 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) call MOM_error(WARNING, 'Error in DOME OBC segment setup', .true.) return !!! Need a better error message here endif + + NTR = tr_Reg%NTR + + ! Stash this information away for the messy tracer restarts. + OBC%ntr = NTR + if (.not. associated(OBC%tracer_x_reservoirs_used)) then + allocate(OBC%tracer_x_reservoirs_used(NTR)) + allocate(OBC%tracer_y_reservoirs_used(NTR)) + OBC%tracer_x_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(1) = .true. + endif + segment => OBC%segment(1) if (.not. segment%on_pe) return - NTR = tr_Reg%NTR allocate(segment%field(NTR)) do k=1,nz From ebd7d12146380376ca58dd4e2abdf3fc61f7aed6 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 3 Oct 2019 16:39:08 -0800 Subject: [PATCH 146/259] *Add OBC code to ALE regrid of u and v - Changes answers due to prior use of h_old, h_new outside. - Outside values did not reproduce on restart, so this helps with restarts. --- src/ALE/MOM_ALE.F90 | 54 +++++++++++++++---- src/core/MOM.F90 | 12 ++--- .../MOM_state_initialization.F90 | 2 +- src/tracer/MOM_offline_main.F90 | 7 +-- 4 files changed, 54 insertions(+), 21 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 8eed4aa925..2f57895980 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -24,6 +24,8 @@ module MOM_ALE use MOM_io, only : vardesc, var_desc, fieldtype, SINGLE_FILE use MOM_io, only : create_file, write_field, close_file use MOM_interface_heights,only : find_eta +use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding use MOM_regridding, only : uniformResolution use MOM_regridding, only : inflate_vanished_layers_old @@ -305,7 +307,7 @@ end subroutine ALE_end !! the old grid and the new grid. The creation of the new grid can be based !! on z coordinates, target interface densities, sigma coordinates or any !! arbitrary coordinate system. -subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, dt, frac_shelf_h) +subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -316,6 +318,7 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, dt, frac_shelf_h) type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure real, optional, intent(in) :: dt !< Time step between calls to ALE_main() real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage ! Local variables @@ -368,7 +371,7 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, dt, frac_shelf_h) call diag_update_remap_grids(CS%diag) endif ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, -dzRegrid, & + call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, -dzRegrid, & u, v, CS%show_call_tree, dt ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") @@ -391,7 +394,7 @@ end subroutine ALE_main !! the old grid and the new grid. The creation of the new grid can be based !! on z coordinates, target interface densities, sigma coordinates or any !! arbitrary coordinate system. -subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) +subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the @@ -399,6 +402,7 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure real, optional, intent(in) :: dt !< Time step between calls to ALE_main() ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions @@ -424,7 +428,8 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, debug=CS%show_call_tree, dt=dt ) + call remap_all_state_vars(CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, & + debug=CS%show_call_tree, dt=dt ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") @@ -443,7 +448,7 @@ end subroutine ALE_main_offline !> Regrid/remap stored fields used for offline tracer integrations. These input fields are assumed to have !! the same layer thicknesses at the end of the last offline interval (which should be a Zstar grid). This !! routine builds a grid on the runtime specified vertical coordinate -subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug) +subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in ) :: G !< Ocean grid informations type(verticalGrid_type), intent(in ) :: GV !< Ocean vertical grid structure @@ -454,6 +459,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug) real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivites logical, intent(in ) :: debug !< If true, then turn checksums + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables integer :: nk, i, j, k, isc, iec, jsc, jec real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! Layer thicknesses after regridding @@ -476,7 +482,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug) if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_offline_inputs)") ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, debug=CS%show_call_tree ) + call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_inputs)") ! Reintegrate mass transports from Zstar to the offline vertical coordinate @@ -523,7 +529,7 @@ end subroutine ALE_offline_inputs !> Remaps all tracers from h onto h_target. This is intended to be called when tracers !! are done offline. In the case where transports don't quite conserve, we still want to !! make sure that layer thicknesses offline do not drift too far away from the online model -subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS) +subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the @@ -533,6 +539,7 @@ subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS) !! last time step [H ~> m or kg-2] type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid !< The change in grid interface positions @@ -551,7 +558,7 @@ subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS) ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, debug=CS%show_call_tree ) + call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_offline_tracer_final)") @@ -638,7 +645,7 @@ end subroutine ALE_build_grid !> For a state-based coordinate, accelerate the process of regridding by !! repeatedly applying the grid calculation algorithm -subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzRegrid, initial) type(ALE_CS), pointer :: CS !< ALE control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Vertical grid @@ -650,6 +657,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, Reg, dt, dzRegrid, intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(tracer_registry_type), & optional, pointer :: Reg !< Tracer registry to remap onto new grid real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding [s] @@ -710,7 +718,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, Reg, dt, dzRegrid, enddo ! remap all state variables (including those that weren't needed for regridding) - call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, dzIntTotal, u, v, dt=dt) + call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v, dt=dt) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) @@ -722,7 +730,8 @@ end subroutine ALE_regrid_accelerated !! This routine is called during initialization of the model at time=0, to !! remap initiali conditions to the model grid. It is also called during a !! time step to update the state. -subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, dxInterface, u, v, debug, dt) +subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, OBC, & + dxInterface, u, v, debug, dt) type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure type(ALE_CS), intent(in) :: CS_ALE !< ALE control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -732,6 +741,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid !! [H ~> m or kg-2] type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(in) :: dxInterface !< Change in interface position !! [H ~> m or kg-2] @@ -852,6 +862,17 @@ 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 + if (associated(OBC)) then + if (OBC%segnum_u(I,j) .ne. 0) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + h1(:) = h_old(i+1,j,:) + h2(:) = h_new(i+1,j,:) + endif + endif + endif 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(:) @@ -874,6 +895,17 @@ 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 + if (associated(OBC)) then + if (OBC%segnum_v(i,J) .ne. 0) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + h1(:) = h_old(i,j+1,:) + h2(:) = h_new(i,j+1,:) + endif + endif + endif 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(:) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f90a614fda..72b8c06413 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1220,10 +1220,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & endif call cpu_clock_begin(id_clock_ALE) if (use_ice_shelf) then - call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, dtdia, & - fluxes%frac_shelf_h) + call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, & + dtdia, fluxes%frac_shelf_h) else - call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, dtdia) + call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, dtdia) endif if (showCallTree) call callTree_waypoint("finished ALE_main (step_MOM_thermo)") @@ -1446,7 +1446,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! 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, CS%h, CS%tv, h_end, CS%tracer_Reg, CS%ALE_CSp, CS%OBC) call cpu_clock_end(id_clock_ALE) call pass_var(CS%h, G%Domain) endif @@ -2228,9 +2228,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! pass to the pointer shelf_area => frac_shelf_h call ALE_main(G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, & - frac_shelf_h = shelf_area) + CS%OBC, frac_shelf_h = shelf_area) else - call ALE_main( G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp ) + call ALE_main( G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC) endif call cpu_clock_begin(id_clock_pass_init) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 1f5401ee58..96447c4212 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -479,7 +479,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (new_sim .and. debug) & call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_m) - call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, tracer_Reg, & + call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & dt=dt, initial=.true.) endif endif diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index bd482e241b..52ad380273 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -5,7 +5,7 @@ module MOM_offline_main ! This file is part of MOM6. See LICENSE.md for the license. use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST -use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs, ALE_offline_tracer_final +use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs use MOM_checksums, only : hchksum, uvchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT @@ -354,7 +354,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock call MOM_tracer_chkinv(debug_msg, G, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call cpu_clock_begin(id_clock_ALE) - call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%dt_offline) + call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, CS%dt_offline) call cpu_clock_end(id_clock_ALE) if (CS%debug) then @@ -1038,7 +1038,8 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) call pass_var(h, CS%G%Domain) call pass_var(CS%tv%T, CS%G%Domain) call pass_var(CS%tv%S, CS%G%Domain) - call ALE_offline_inputs(CS%ALE_CSp, CS%G, CS%GV, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, CS%debug) + call ALE_offline_inputs(CS%ALE_CSp, CS%G, CS%GV, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & + CS%debug, CS%OBC) if (CS%id_temp_regrid>0) call post_data(CS%id_temp_regrid, CS%tv%T, CS%diag) if (CS%id_salt_regrid>0) call post_data(CS%id_salt_regrid, CS%tv%S, CS%diag) if (CS%id_uhtr_regrid>0) call post_data(CS%id_uhtr_regrid, CS%uhtr, CS%diag) From dfd52787c262029b5dae0c56a35317ab8556fd30 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 04:19:17 -0400 Subject: [PATCH 147/259] +Changed units of fluxes%TKE_tidal to [R Z3 T-3] Changed the units of fluxes%TKE_tidal to [R Z3 T-3] and rescaled the internal representation of the tidal velocities to [Z T-1] in varoius forcing routines for dimensional consistency testing. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 20 +++++++++---------- .../mct_driver/mom_surface_forcing_mct.F90 | 20 +++++++++---------- .../mom_surface_forcing_nuopc.F90 | 20 +++++++++---------- src/core/MOM_forcing_type.F90 | 7 ++++--- .../vertical/MOM_set_diffusivity.F90 | 8 ++++---- 5 files changed, 38 insertions(+), 37 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index c91bde8fc6..61d9c60d1d 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -89,14 +89,14 @@ module MOM_surface_forcing_gfdl logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL() !< Turbulent kinetic energy introduced to the bottom boundary layer - !! by drag on the tidal flows [W m-2]. + !! by drag on the tidal flows [R Z3 T-3 ~> W m-2]. real, pointer, dimension(:,:) :: & gust => NULL() !< A spatially varying unresolved background gustiness that !! contributes to ustar [R L Z T-1 ~> Pa]. gust is used when read_gust_2d is true. real, pointer, dimension(:,:) :: & - ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [m s-1] + ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< Drag coefficient that applies to the tides (nondimensional) - real :: utide !< Constant tidal velocity to use if read_tideamp is false [m s-1]. + real :: utide !< Constant tidal velocity to use if read_tideamp is false [Z T-1 ~> m s-1]. logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts to damp surface @@ -298,7 +298,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) - fluxes%ustar_tidal(i,j) = US%m_to_Z*US%T_to_s*CS%ustar_tidal(i,j) + fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo if (CS%restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) @@ -1218,7 +1218,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) !! structure for this module ! Local variables - real :: utide ! The RMS tidal velocity [m s-1]. + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs logical :: new_sim, iceberg_flux_diags logical :: default_2018_answers @@ -1429,7 +1429,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) else call get_param(param_file, mdl, "UTIDE", CS%utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) @@ -1437,16 +1437,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1) + call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied - utide=CS%utide - CS%TKE_tidal(i,j) = US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) + utide = CS%utide + CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 1eeb71c44c..7072c406e8 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -83,14 +83,14 @@ module MOM_surface_forcing_mct !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the - !! bottom boundary layer by drag on the tidal flows [W m-2] + !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] gust => NULL(), & !< spatially varying unresolved background !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. !! gust is used when read_gust_2d is true. - ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [m/s] + ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) real :: utide !< constant tidal velocity to use if read_tideamp - !! is false [m s-1] + !! is false [Z T-1 ~> m s-1] logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts !! to damp surface deflections (especially surface @@ -301,7 +301,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) - fluxes%ustar_tidal(i,j) = US%m_to_Z*US%T_to_s*CS%ustar_tidal(i,j) + fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) @@ -1002,7 +1002,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, !! restoring will be applied in this model. ! Local variables - real :: utide ! The RMS tidal velocity, in m s-1. + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs logical :: new_sim, iceberg_flux_diags type(time_type) :: Time_frc @@ -1199,7 +1199,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, else call get_param(param_file, mdl, "UTIDE", CS%utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) @@ -1207,16 +1207,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1) + call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied - utide=CS%utide - CS%TKE_tidal(i,j) = US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) + utide = CS%utide + CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 96645f10d2..7e56780a36 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -85,14 +85,14 @@ module MOM_surface_forcing_nuopc !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the - !! bottom boundary layer by drag on the tidal flows [W m-2] + !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] gust => NULL(), & !< spatially varying unresolved background !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. !! gust is used when read_gust_2d is true. - ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [m s-1] + ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) real :: utide !< constant tidal velocity to use if read_tideamp - !! is false [m s-1] + !! is false [Z T-1 ~> m s-1] logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts @@ -306,7 +306,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) - fluxes%ustar_tidal(i,j) = US%m_to_Z*US%T_to_s*CS%ustar_tidal(i,j) + fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) @@ -998,7 +998,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, !! restoring will be applied in this model. ! Local variables - real :: utide ! The RMS tidal velocity, in m s-1. + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs logical :: new_sim, iceberg_flux_diags type(time_type) :: Time_frc @@ -1195,7 +1195,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, else call get_param(param_file, mdl, "UTIDE", CS%utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) @@ -1203,16 +1203,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1) + call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied - utide=CS%utide - CS%TKE_tidal(i,j) = US%R_to_kg_m3*CS%Rho0*CS%cd_tides*(utide*utide*utide) + utide = CS%utide + CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index e34c4f243d..2b064a2834 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -130,7 +130,7 @@ module MOM_forcing_type ! tide related inputs real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & !< tidal energy source driving mixing in bottom boundary layer [W m-2] + TKE_tidal => NULL(), & !< tidal energy source driving mixing in bottom boundary layer [R Z3 T-3 ~> W m-2] ustar_tidal => NULL() !< tidal contribution to bottom ustar [Z T-1 ~> m s-1] ! iceberg related inputs @@ -1061,7 +1061,8 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%salt_flux)) & call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux",G%HI,haloshift=hshift) if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal",G%HI,haloshift=hshift) + call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal",G%HI,haloshift=hshift, & + scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) if (associated(fluxes%ustar_tidal)) & call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & @@ -1257,7 +1258,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='sea_water_pressure_at_sea_water_surface') handles%id_TKE_tidal = register_diag_field('ocean_model', 'TKE_tidal', diag%axesT1, Time, & - 'Tidal source of BBL mixing', 'W m-2') + 'Tidal source of BBL mixing', 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) if (.not. use_temperature) then handles%id_buoy = register_diag_field('ocean_model', 'buoy', diag%axesT1, Time, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 6e453138fb..ad6fbe11a0 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1202,7 +1202,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & - TKE(i) = TKE(i) + (US%kg_m3_to_R * US%T_to_s**3 * US%m_to_Z**3 * fluxes%TKE_tidal(i,j)) * I_Rho0 * & + TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following @@ -1418,10 +1418,10 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! (Note that visc%TKE_BBL is in [Z3 T-3 ~> m3 s-3], set in set_BBL_TKE().) ! I am still unsure about sqrt(cdrag) in this expressions - AJA TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) - ! Add in tidal dissipation energy at the bottom [m3 s-3]. - ! Note that TKE_tidal is in [W m-2]. + ! Add in tidal dissipation energy at the bottom [R Z3 T-3 ~> m3 s-3]. + ! Note that TKE_tidal is in [R Z3 T-3 ~> W m-2]. if (associated(fluxes%TKE_tidal)) & - TKE_column = TKE_column + US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 * fluxes%TKE_tidal(i,j) * I_Rho0 + TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column From d7f08f512da1493fc15b1c08b858d1d9b506a906 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 10:33:31 -0400 Subject: [PATCH 148/259] +Rescaled density units in coord_hycom.F90 Optionally rescaled density units in coord_slight for dimensional consistency testing, as determined by the presence and value of a new optional argument, rho_scale, to init_coord_hycom. All answers are bitwise identical. --- src/ALE/coord_hycom.F90 | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 6928425e33..76c346c82e 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -18,9 +18,12 @@ module coord_hycom !> Nominal near-surface resolution real, allocatable, dimension(:) :: coordinateResolution - !> Nominal density of interfaces + !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density + !> Density scaling factor [R m3 kg-1 ~> 1] + real :: kg_m3_to_R + !> Maximum depths of interfaces real, allocatable, dimension(:) :: max_interface_depths @@ -36,12 +39,13 @@ module coord_hycom contains !> Initialise a hycom_CS with pointers to parameters -subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS) +subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS, rho_scale) type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in generated grid real, dimension(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] - real, dimension(nk+1),intent(in) :: target_density !< Interface target densities [kg m-3] + real, dimension(nk+1),intent(in) :: target_density !< Interface target densities [R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation + real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density if (associated(CS)) call MOM_error(FATAL, "init_coord_hycom: CS already associated!") allocate(CS) @@ -52,6 +56,8 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%coordinateResolution(:) = coordinateResolution(:) CS%target_density(:) = target_density(:) CS%interp_CS = interp_CS + CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale + end subroutine init_coord_hycom !> This subroutine deallocates memory in the control structure for the coord_hycom module @@ -117,7 +123,7 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & ! Local variables integer :: k - real, dimension(nz) :: rho_col ! Layer quantities + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] real, dimension(CS%nk) :: h_col_new ! New layer thicknesses real :: z_scale real :: stretching ! z* stretching, converts z* to z. @@ -132,7 +138,7 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & 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) + call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) ! This ensures the potential density profile is monotonic ! although not necessarily single valued. do k = nz-1, 1, -1 From e9b36cc080287e3eda761c48b44c3f49f38a43aa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 10:33:52 -0400 Subject: [PATCH 149/259] +Rescaled density units in coord_slight.F90 Optionally rescaled density units in coord_slight for dimensional consistency testing, as determined by the presence and value of a new optional argument, rho_scale, to init_coord_slight. All answers are bitwise identical. --- src/ALE/coord_slight.F90 | 42 ++++++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 14 deletions(-) diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 8eb623d664..2e41d36473 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -51,9 +51,12 @@ module coord_slight !> A value of the stratification ratio that defines a problematic halocline region [nondim]. real :: halocline_strat_tol - !> Nominal density of interfaces [kg m-3]. + !> Nominal density of interfaces [R ~> kg m-3]. real, allocatable, dimension(:) :: target_density + !> Density scaling factor [R m3 kg-1 ~> 1] + real :: kg_m3_to_R + !> Maximum depths of interfaces [H ~> m or kg m-2]. real, allocatable, dimension(:) :: max_interface_depths @@ -69,13 +72,14 @@ module coord_slight contains !> Initialise a slight_CS with pointers to parameters -subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H) +subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H, rho_scale) type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in the grid real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses + real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density real :: m_to_H_rescale ! A unit conversion factor. @@ -97,6 +101,7 @@ subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_ CS%dz_ml_min = 1.0 * m_to_H_rescale CS%halocline_filter_length = 2.0 * m_to_H_rescale CS%halocline_strat_tol = 0.25 ! Nondim. + CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale end subroutine init_coord_slight @@ -197,23 +202,32 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose !! of edge value calculations [H ~> m or kg m-2]. ! Local variables - real, dimension(nz) :: rho_col ! Layer quantities + real, dimension(nz) :: rho_col ! Layer densities [R ~> kg m-3] real, dimension(nz) :: T_f, S_f ! Filtered ayer quantities logical, dimension(nz+1) :: reliable ! If true, this interface is in a reliable position. real, dimension(nz+1) :: T_int, S_int ! Temperature and salinity interpolated to interfaces. - real, dimension(nz+1) :: rho_tmp, drho_dp, p_IS, p_R - real, dimension(nz+1) :: drhoIS_dT, drhoIS_dS - real, dimension(nz+1) :: drhoR_dT, drhoR_dS + real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] + real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [kg m-3 Pa-1] + real, dimension(nz+1) :: p_IS, p_R + real, dimension(nz+1) :: drhoIS_dT ! The partial derivative of in situ density with temperature + ! in [R degC-1 ~> kg m-3 degC-1] + real, dimension(nz+1) :: drhoIS_dS ! The partial derivative of in situ density with salinity + ! in [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(nz+1) :: drhoR_dT ! The partial derivative of reference density with temperature + ! in [R degC-1 ~> kg m-3 degC-1] + real, dimension(nz+1) :: drhoR_dS ! The partial derivative of reference density with salinity + ! in [R ppt-1 ~> kg m-3 ppt-1] real, dimension(nz+1) :: strat_rat real :: H_to_cPa - real :: drIS, drR, Fn_now, I_HStol, Fn_zero_val + real :: drIS, drR ! In situ and reference density differences [R ~> kg m-3] + real :: Fn_now, I_HStol, Fn_zero_val real :: z_int_unst real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. real :: wgt, cowgt ! A weight and its complement, nondim. - real :: rho_ml_av ! The average potential density in a near-surface region [kg m-3]. + real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. - real :: rho_x_z ! A cumulative integral of a density [kg m-3 H ~> kg m-2 or kg2 m-5]. + real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. real :: k_interior ! The (real) value of k where the interior grid starts. real :: k_int2 ! The (real) value of k where the interior grid starts. @@ -241,7 +255,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo else call calculate_density(T_col, S_col, p_col, rho_col, 1, nz, & - eqn_of_state) + eqn_of_state, scale=CS%kg_m3_to_R) ! Find the locations of the target potential densities, flagging ! locations in apparently unstable regions as not reliable. @@ -363,9 +377,9 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) p_IS(nz+1) = z_col(nz+1) * H_to_Pa call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, 2, nz-1, & - eqn_of_state) + eqn_of_state, scale=CS%kg_m3_to_R) call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, 2, nz-1, & - eqn_of_state) + eqn_of_state, scale=CS%kg_m3_to_R) if (CS%compressibility_fraction > 0.0) then call calculate_compress(T_int, S_int, p_R, rho_tmp, drho_dp, 2, nz-1, & eqn_of_state) @@ -373,7 +387,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & do K=2,nz ; drho_dp(K) = 0.0 ; enddo endif - H_to_cPa = CS%compressibility_fraction*H_to_Pa + H_to_cPa = CS%compressibility_fraction*CS%kg_m3_to_R*H_to_Pa strat_rat(1) = 1.0 do K=2,nz drIS = drhoIS_dT(K) * (T_f(k) - T_f(k-1)) + & @@ -462,7 +476,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. ! Recall that z_col_new is positive downward. z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K), & - z_col_new(K-1) + CS%max_layer_thickness(k-1)) + z_col_new(K-1) + CS%max_layer_thickness(k-1)) enddo ; elseif (maximum_depths_set) then ; do K=2,nz z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K)) enddo ; elseif (maximum_h_set) then ; do k=2,nz From 1175786ea4aa73d85423d055f45d11e032a80b3a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 10:34:10 -0400 Subject: [PATCH 150/259] Rescaled density units in MOM_regridding.F90 Rescaled density units in MOM_regridding.F90, including using the new optional arguments to init_coord_hycom, init_coord_rho, and init_coord_slight to rescale densities in those modules as well. All answers are bitwise identical. --- src/ALE/MOM_regridding.F90 | 60 +++++++++++++++++++++----------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 6af95c2ce4..0cb012b208 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -46,7 +46,7 @@ module MOM_regridding !> This array is set by function setCoordinateResolution() !! It contains the "resolution" or delta coordinate of the target - !! coorindate. It has the units of the target coordinate, e.g. + !! coordinate. It has the units of the target coordinate, e.g. !! [Z ~> m] for z*, non-dimensional for sigma, etc. real, dimension(:), allocatable :: coordinateResolution @@ -56,9 +56,9 @@ module MOM_regridding !> This array is set by function set_target_densities() !! This array is the nominal coordinate of interfaces and is the - !! running sum of coordinateResolution. i.e. + !! running sum of coordinateResolution, in [R ~> kg m-3]. i.e. !! target_density(k+1) = coordinateResolution(k) + coordinateResolution(k) - !! It is only used in "rho" mode. + !! It is only used in "rho", "SLight" or "Hycom" mode. real, dimension(:), allocatable :: target_density !> A flag to indicate that the target_density arrays has been filled with data. @@ -199,8 +199,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha integer :: nz_fixed_sfc, k, nzf(4) - real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be - ! [m] or [Z ~> m] or [H ~> m or kg m-2] or [kg m-3] or other units. + real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] + ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2] real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other ! units depending on the coordinate @@ -310,13 +310,9 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m 'Unable to interpret "'//trim(string)//'".') endif allocate(dz(ke)) - if (ke==1) then - dz(:) = uniformResolution(ke, coord_mode, tmpReal, US%R_to_kg_m3*GV%Rlay(1), US%R_to_kg_m3*GV%Rlay(1)) - else - dz(:) = uniformResolution(ke, coord_mode, tmpReal, & - US%R_to_kg_m3*(GV%Rlay(1)+0.5*(GV%Rlay(1)-GV%Rlay(2))), & - US%R_to_kg_m3*(GV%Rlay(ke)+0.5*(GV%Rlay(ke)-GV%Rlay(ke-1))) ) - endif + dz(:) = uniformResolution(ke, coord_mode, tmpReal, & + US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & + US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=trim(coord_units)) elseif (trim(string)=='PARAM') then @@ -469,13 +465,15 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m allocate( CS%coordinateResolution(CS%nk) ); CS%coordinateResolution(:) = -1.E30 if (state_dependent(CS%regridding_scheme)) then ! Target values - allocate( CS%target_density(CS%nk+1) ); CS%target_density(:) = -1.E30 + allocate( CS%target_density(CS%nk+1) ); CS%target_density(:) = -1.E30*US%kg_m3_to_R endif if (allocated(dz)) then - if ((coordinateMode(coord_mode) == REGRIDDING_SIGMA) .or. & - (coordinateMode(coord_mode) == REGRIDDING_RHO)) then + if (coordinateMode(coord_mode) == REGRIDDING_SIGMA) then call setCoordinateResolution(dz, CS, scale=1.0) + elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then + call setCoordinateResolution(dz, CS, scale=US%kg_m3_to_R) + CS%coord_scale = US%R_to_kg_m3 elseif (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then call setCoordinateResolution(dz, CS, scale=GV%m_to_H) CS%coord_scale = GV%H_to_m @@ -486,18 +484,18 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif if (allocated(rho_target)) then - call set_target_densities(CS, rho_target) + call set_target_densities(CS, US%kg_m3_to_R*rho_target) deallocate(rho_target) ! \todo This line looks like it would overwrite the target densities set just above? elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then call set_target_densities_from_GV(GV, US, CS) - call log_param(param_file, mdl, "!TARGET_DENSITIES", CS%target_density, & + call log_param(param_file, mdl, "!TARGET_DENSITIES", US%R_to_kg_m3*CS%target_density(:), & 'RHO target densities for interfaces', units=coordinateUnits(coord_mode)) endif ! initialise coordinate-specific control structure - call initCoord(CS, GV, coord_mode) + call initCoord(CS, GV, US, coord_mode) if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & @@ -1947,12 +1945,13 @@ end function uniformResolution !> Initialize the coordinate resolutions by calling the appropriate initialization !! routine for the specified coordinate mode. -subroutine initCoord(CS, GV, coord_mode) +subroutine initCoord(CS, GV, US, coord_mode) type(regridding_CS), intent(inout) :: CS !< Regridding control structure character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. !! See the documenttion for regrid_consts !! for the recognized values. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type select case (coordinateMode(coord_mode)) case (REGRIDDING_ZSTAR) @@ -1962,11 +1961,14 @@ subroutine initCoord(CS, GV, coord_mode) case (REGRIDDING_SIGMA) call init_coord_sigma(CS%sigma_CS, CS%nk, CS%coordinateResolution) case (REGRIDDING_RHO) - call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS) + call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS, & + rho_scale=US%kg_m3_to_R) case (REGRIDDING_HYCOM1) - call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, CS%interp_CS) + call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & + CS%interp_CS, rho_scale=US%kg_m3_to_R) case (REGRIDDING_SLIGHT) - call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS, GV%m_to_H) + call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & + CS%interp_CS, GV%m_to_H, rho_scale=US%kg_m3_to_R) case (REGRIDDING_ADAPTIVE) call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H) end select @@ -1999,8 +2001,8 @@ subroutine set_target_densities_from_GV( GV, US, CS ) integer :: k, nz nz = CS%nk - CS%target_density(1) = US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) - CS%target_density(nz+1) = US%R_to_kg_m3*(GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) + CS%target_density(1) = (GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(2))) + CS%target_density(nz+1) = (GV%Rlay(nz) + 0.5*(GV%Rlay(nz)-GV%Rlay(nz-1))) do k = 2,nz CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) enddo @@ -2011,7 +2013,7 @@ end subroutine set_target_densities_from_GV !> Set target densities based on vector of interface values subroutine set_target_densities( CS, rho_int ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure - real, dimension(CS%nk+1), intent(in) :: rho_int !< Interface densities + real, dimension(CS%nk+1), intent(in) :: rho_int !< Interface densities [R ~> kg m-3] if (size(CS%target_density)/=size(rho_int)) then call MOM_error(FATAL, "set_target_densities inconsistent args!") @@ -2124,7 +2126,11 @@ function getCoordinateInterfaces( CS, undo_scaling ) call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//& 'target densities not set!') - getCoordinateInterfaces(:) = CS%target_density(:) + if (unscale) then + getCoordinateInterfaces(:) = CS%coord_scale * CS%target_density(:) + else + getCoordinateInterfaces(:) = CS%target_density(:) + endif else if (unscale) then getCoordinateInterfaces(1) = 0. @@ -2402,7 +2408,7 @@ end subroutine dz_function1 integer function rho_function1( string, rho_target ) character(len=*), intent(in) :: string !< String with list of parameters in form !! dz_min, H_total, power, precision - real, dimension(:), allocatable, intent(inout) :: rho_target !< Profile of interface densities + real, dimension(:), allocatable, intent(inout) :: rho_target !< Profile of interface densities [kg m-3] ! Local variables integer :: nki, k, nk real :: ddx, dx, rho_1, rho_2, rho_3, drho, rho_4, drho_min From 3b4ea9c7bb4b327abb4d931153ddfb30825533a0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 11:36:33 -0400 Subject: [PATCH 151/259] +Turned heat budget pointers into arrays Turned pointers to heat budget elements in the surface type into arrays, so that the internal units can be changed without impacting the externally used arrays. This also included passing in a thermo_var_ptrs type as a new argument to accumulate_net_input, which is appropriate now that this routine is only called from inside of step_MOM. All answers are bitwise identical, but an interface has a new argument. --- src/core/MOM.F90 | 28 +++++++++++++++++++++++++--- src/core/MOM_variables.F90 | 21 ++++++++++----------- src/diagnostics/MOM_sum_output.F90 | 18 ++++++++++-------- 3 files changed, 45 insertions(+), 22 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a99e6d7624..db3399c398 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -851,7 +851,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! Accumulate the surface fluxes for assessing conservation if (do_thermo .and. fluxes%fluxes_used) & - call accumulate_net_input(fluxes, sfc_state, fluxes%dt_buoy_accum, & + call accumulate_net_input(fluxes, sfc_state, CS%tv, fluxes%dt_buoy_accum, & G, CS%sum_output_CSp) if (MOM_state_is_synchronized(CS)) & @@ -2737,8 +2737,6 @@ subroutine extract_surface_state(CS, sfc_state) call allocate_surface_state(sfc_state, G, 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 if (associated(CS%visc%taux_shelf)) sfc_state%taux_shelf => CS%visc%taux_shelf @@ -2927,6 +2925,30 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%salt_deficit(i,j) = 1000.0 * CS%tv%salt_deficit(i,j) enddo ; enddo endif + if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + sfc_state%TempxPmE(i,j) = CS%tv%TempxPmE(i,j) + enddo ; enddo + endif + if (allocated(sfc_state%internal_heat) .and. associated(CS%tv%internal_heat)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + sfc_state%internal_heat(i,j) = CS%tv%internal_heat(i,j) + enddo ; enddo + endif + if (associated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + sfc_state%taux_shelf(I,j) = CS%visc%taux_shelf(I,j) + enddo ; enddo + endif + if (associated(sfc_state%tauy_shelf) .and. associated(CS%visc%tauy_shelf)) then + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + sfc_state%tauy_shelf(i,J) = CS%visc%tauy_shelf(i,J) + enddo ; enddo + endif if (allocated(sfc_state%ocean_mass) .and. allocated(sfc_state%ocean_heat) .and. & allocated(sfc_state%ocean_salt)) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 36148f69ba..cca22cf31b 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -50,8 +50,12 @@ module MOM_variables ocean_mass, & !< The total mass of the ocean [kg m-2]. ocean_heat, & !< The total heat content of the ocean in [degC kg m-2]. 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 + TempxPmE, & !< The net inflow of water into the ocean times the temperature at which this + !! inflow occurs during the call to step_MOM [degC kg 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 [kgSalt m-2]. + internal_heat !< Any internal or geothermal heat sources that are applied to the ocean + !! integrated over the call to step_MOM [degC kg 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 @@ -62,13 +66,6 @@ module MOM_variables real, pointer, dimension(:,:) :: frazil => NULL() !< The energy needed to heat the ocean column to the freezing point during the call !! to step_MOM [J m-2]. - real, pointer, dimension(:,:) :: TempxPmE => NULL() - !< The net inflow of water into the ocean times the temperature at which this inflow - !! occurs during the call to step_MOM [degC kg m-2]. This should be prescribed in the - !! forcing fields, but as it often is not, this is a useful heat budget diagnostic. - real, pointer, dimension(:,:) :: internal_heat => NULL() - !< Any internal or geothermal heat sources that are applied to the ocean integrated - !! over the call to step_MOM [degC kg m-2]. type(coupler_2d_bc_type) :: tr_fields !< A structure that may contain an !! array of named fields describing tracer-related quantities. !### NOTE: ALL OF THE ARRAYS IN TR_FIELDS USE THE COUPLER'S INDEXING CONVENTION AND HAVE NO @@ -127,8 +124,8 @@ module MOM_variables real, pointer, dimension(:,:,:) :: & T => NULL(), & !< Pointer to the temperature state variable [degC] S => NULL(), & !< Pointer to the salinity state variable [ppt ~> PSU or g/kg] - u => NULL(), & !< Pointer to the zonal velocity [m s-1] - v => NULL(), & !< Pointer to the meridional velocity [m s-1] + u => NULL(), & !< Pointer to the zonal velocity [L T-1 ~> m s-1] + v => NULL(), & !< Pointer to the meridional velocity [L T-1 ~> m s-1] h => NULL() !< Pointer to the layer thicknesses [H ~> m or kg m-2] real, pointer, dimension(:,:,:) :: & uh => NULL(), & !< Pointer to zonal transports [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -349,8 +346,10 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & if (use_temp) then allocate(sfc_state%ocean_heat(isd:ied,jsd:jed)) ; sfc_state%ocean_heat(:,:) = 0.0 allocate(sfc_state%ocean_salt(isd:ied,jsd:jed)) ; sfc_state%ocean_salt(:,:) = 0.0 + allocate(sfc_state%TempxPmE(isd:ied,jsd:jed)) ; sfc_state%TempxPmE(:,:) = 0.0 + allocate(sfc_state%salt_deficit(isd:ied,jsd:jed)) ; sfc_state%salt_deficit(:,:) = 0.0 + allocate(sfc_state%internal_heat(isd:ied,jsd:jed)) ; sfc_state%internal_heat(:,:) = 0.0 endif - allocate(sfc_state%salt_deficit(isd:ied,jsd:jed)) ; sfc_state%salt_deficit(:,:) = 0.0 endif if (present(gas_fields_ocn)) & diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 9d8cff542f..1a8a9879b3 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -936,11 +936,13 @@ end subroutine write_energy !> This subroutine accumates the net input of volume, salt and heat, through !! the ocean surface for use in diagnosing conservation. -subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) +subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, CS) type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible !! forcing fields. Unused fields are unallocated. type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. real, intent(in) :: dt !< The amount of time over which to average [s]. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call @@ -1004,7 +1006,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) ! smg: new code ! include heat content from water transport across ocean surface ! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie -! heat_in(i,j) = heat_in(i,j) + dt*G%US%L_to_m**2*G%areaT(i,j) * & +! heat_in(i,j) = heat_in(i,j) + dt*G%US%L_to_m**2*G%areaT(i,j) * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) & ! + (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) & ! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & @@ -1012,9 +1014,9 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) ! enddo ; enddo ; endif ! smg: old code - if (associated(sfc_state%TempxPmE)) then + if (associated(tv%TempxPmE)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (C_p * G%US%L_to_m**2*G%areaT(i,j)) * sfc_state%TempxPmE(i,j) + heat_in(i,j) = heat_in(i,j) + (C_p * G%US%L_to_m**2*G%areaT(i,j)) * tv%TempxPmE(i,j) enddo ; enddo elseif (associated(fluxes%evap)) then do j=js,je ; do i=is,ie @@ -1024,14 +1026,14 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) ! The following heat sources may or may not be used. - if (associated(sfc_state%internal_heat)) then + if (associated(tv%internal_heat)) then do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + (C_p * G%US%L_to_m**2*G%areaT(i,j)) * & - sfc_state%internal_heat(i,j) + tv%internal_heat(i,j) enddo ; enddo endif - if (associated(sfc_state%frazil)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + G%US%L_to_m**2*G%areaT(i,j) * sfc_state%frazil(i,j) + if (associated(tv%frazil)) then ; do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + G%US%L_to_m**2*G%areaT(i,j) * tv%frazil(i,j) enddo ; enddo ; endif if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + dt*G%US%L_to_m**2*G%areaT(i,j)*fluxes%heat_added(i,j) From 2fc1b094ac26514ee3cb5f1713dd22353cd72d5b Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 4 Oct 2019 10:27:01 -0800 Subject: [PATCH 152/259] My understanding of OBC_RAD_VEL_WT was wrong. --- src/core/MOM_open_boundary.F90 | 50 +++++++++++++++++----------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 701416cf37..4a2b734e99 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1761,7 +1761,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) !! Copy previously calculated phase velocity from global arrays into segments !! This is terribly inefficient and temporary solution for continuity across restarts !! and needs to be revisited in the future. - if (OBC%gamma_uv > 0.0) then + if (OBC%gamma_uv < 1.0) then do n=1,OBC%number_of_segments segment=>OBC%segment(n) if (.not. segment%on_pe) cycle @@ -1847,7 +1847,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = (u_new(I-1,j,k) - u_new(I-2,j,k)) !in new time backward sasha for I-1 rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new else rx_avg = rx_new @@ -1859,7 +1859,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) endif elseif (segment%oblique) then @@ -1876,7 +1876,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = US%L_T_to_m_s**2*dhdt*dhdx cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new @@ -1892,7 +1892,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & (cff_avg + rx_avg) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary ! implementation as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -1918,7 +1918,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 @@ -1991,7 +1991,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) @@ -2091,7 +2091,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = (u_new(I+1,j,k) - u_new(I+2,j,k)) !in new time forward sasha for I+1 rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new else rx_avg = rx_new @@ -2101,7 +2101,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! value, u_new(I+1) and past boundary value but with barotropic ! accelerations, u_new(I). segment%normal_vel(I,j,k) = (u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -2121,7 +2121,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = US%L_T_to_m_s**2*dhdt*dhdx cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new @@ -2137,7 +2137,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & (cff_avg + rx_avg) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -2163,7 +2163,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 @@ -2236,7 +2236,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) @@ -2336,7 +2336,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = (v_new(i,J-1,k) - v_new(i,J-2,k)) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new else ry_avg = ry_new @@ -2346,7 +2346,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! value, v_new(J-1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) @@ -2365,7 +2365,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new @@ -2381,7 +2381,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -2407,7 +2407,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) J=segment%HI%JsdB allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 @@ -2480,7 +2480,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) @@ -2580,7 +2580,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = (v_new(i,J+1,k) - v_new(i,J+2,k)) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new else ry_avg = ry_new @@ -2590,7 +2590,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! value, v_new(J+1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) @@ -2610,7 +2610,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = US%L_T_to_m_s**2*dhdt*dhdy cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new @@ -2626,7 +2626,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & (cff_avg + ry_avg) - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) @@ -2652,7 +2652,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) J=segment%HI%JsdB allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 @@ -2725,7 +2725,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - if (gamma_u > 0.0) then + if (gamma_u < 1.0) then rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) From fa35255590dd51115e5a7f6b9f95cbe5bccd650f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 14:33:01 -0400 Subject: [PATCH 153/259] +Rescaled the units of taux_shelf and tauy_shelf Rescaled the units of the taux_shelf and tauy_shelf elements of the vertvisc_type to [R Z L T-2], and made these elements of the surface type into allocatable arrays so that they can retain units of [Pa]. Also added code to allocate these arrays as needed. In addition, commented out the improper code setting taux_shelf and tauy_shelf as a non-vector in shelf_calc_flux, but this was not being used anyway. Also canceled out rescaling factors in the expressions for taux_bot and tauy_bot in vertvisc. All answers are bitwise identical in the MOM6-examples test cases, and should be unaltered in other cases. --- src/core/MOM.F90 | 10 +++---- src/core/MOM_variables.F90 | 21 ++++++++++----- src/ice_shelf/MOM_ice_shelf.F90 | 26 ++++++++++++------- .../vertical/MOM_set_viscosity.F90 | 8 +++--- .../vertical/MOM_vert_friction.F90 | 14 +++++----- 5 files changed, 45 insertions(+), 34 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index db3399c398..f4ef5a1376 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2739,8 +2739,6 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%frazil => CS%tv%frazil 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 do j=js,je ; do i=is,ie sfc_state%sea_lev(i,j) = CS%ave_ssh_ibc(i,j) @@ -2937,16 +2935,16 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%internal_heat(i,j) = CS%tv%internal_heat(i,j) enddo ; enddo endif - if (associated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then + if (allocated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - sfc_state%taux_shelf(I,j) = CS%visc%taux_shelf(I,j) + sfc_state%taux_shelf(I,j) = US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*CS%visc%taux_shelf(I,j) enddo ; enddo endif - if (associated(sfc_state%tauy_shelf) .and. associated(CS%visc%tauy_shelf)) then + if (allocated(sfc_state%tauy_shelf) .and. associated(CS%visc%tauy_shelf)) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - sfc_state%tauy_shelf(i,J) = CS%visc%tauy_shelf(i,J) + sfc_state%tauy_shelf(i,J) = US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*CS%visc%tauy_shelf(i,J) enddo ; enddo endif diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index cca22cf31b..22d03e9086 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -50,6 +50,8 @@ module MOM_variables ocean_mass, & !< The total mass of the ocean [kg m-2]. ocean_heat, & !< The total heat content of the ocean in [degC kg m-2]. ocean_salt, & !< The total salt content of the ocean in [kgSalt m-2]. + taux_shelf, & !< The zonal stresses on the ocean under shelves [Pa]. + tauy_shelf, & !< The meridional stresses on the ocean under shelves [Pa]. TempxPmE, & !< The net inflow of water into the ocean times the temperature at which this !! inflow occurs during the call to step_MOM [degC kg m-2]. salt_deficit, & !< The salt needed to maintain the ocean column at a minimum @@ -60,9 +62,6 @@ module MOM_variables !! 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 stresses on the ocean under shelves [Pa]. - tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [Pa]. real, pointer, dimension(:,:) :: frazil => NULL() !< The energy needed to heat the ocean column to the freezing point during the call !! to step_MOM [J m-2]. @@ -208,8 +207,8 @@ module MOM_variables !! energy, currently in [Z3 T-3 ~> m3 s-3], but may at some time be changed !! to [kg Z3 m-3 T-3 ~> W m-2]. real, pointer, dimension(:,:) :: & - taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [Pa]. - tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [Pa]. + taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [R Z L T-2 ~> Pa]. + tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [R Z L T-2 ~> Pa]. real, pointer, dimension(:,:) :: tbl_thick_shelf_u => NULL() !< Thickness of the viscous top boundary layer under ice shelves at u-points [Z ~> m]. real, pointer, dimension(:,:) :: tbl_thick_shelf_v => NULL() @@ -296,7 +295,7 @@ module MOM_variables !> Allocates the fields for the surface (return) properties of !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & - gas_fields_ocn, use_meltpot) + gas_fields_ocn, use_meltpot, use_iceshelves) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. @@ -309,9 +308,11 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. logical, optional, intent(in) :: use_meltpot !< If true, allocate the space for melt potential + logical, optional, intent(in) :: use_iceshelves !< If true, allocate the space for the stresses + !! under ice shelves. ! local variables - logical :: use_temp, alloc_integ, use_melt_potential + logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -322,6 +323,7 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & use_temp = .true. ; if (present(use_temperature)) use_temp = use_temperature alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot + alloc_iceshelves = .false. ; if (present(use_iceshelves)) alloc_iceshelves = use_iceshelves if (sfc_state%arrays_allocated) return @@ -352,6 +354,11 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & endif endif + if (alloc_iceshelves) then + allocate(sfc_state%taux_shelf(IsdB:IedB,jsd:jed)) ; sfc_state%taux_shelf(:,:) = 0.0 + allocate(sfc_state%tauy_shelf(isd:ied,JsdB:JedB)) ; sfc_state%tauy_shelf(:,:) = 0.0 + endif + if (present(gas_fields_ocn)) & call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d07fe42676..ca8f3049ee 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -190,8 +190,9 @@ module MOM_ice_shelf !! formulation (optional to use just two equations). !! See \ref section_ICE_SHELF_equations subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) - type(surface), intent(inout) :: state !< structure containing fields that - !!describe the surface state of the ocean + type(surface), intent(inout) :: state !< A structure containing fields that + !! describe the surface state of the ocean. The + !! intent is only inout to allow for halo updates. type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible !! thermodynamic or mass-flux forcing fields. type(time_type), intent(in) :: Time !< Start time of the fluxes. @@ -336,7 +337,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) do i=is,ie ; p_int(i) = CS%g_Earth * ISS%mass_shelf(i,j) ; enddo ! Calculate insitu densities and expansion coefficients - call calculate_density(state%sst(:,j),state%sss(:,j), p_int, & + call calculate_density(state%sst(:,j), state%sss(:,j), p_int, & Rhoml(:), is, ie-is+1, CS%eqn_of_state) call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, & dR0_dT, dR0_dS, is, ie-is+1, CS%eqn_of_state) @@ -363,15 +364,20 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) v_at_h = state%v(i,j) !### I think that CS%utide**1 should be CS%utide**2 + ! Also I think that if taux_shelf and tauy_shelf have been calculated by the + ! ocean stress calculation, they should be used here or later to set ustar_shelf. - RWH fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s * & sqrt(CS%cdrag*((u_at_h**2 + v_at_h**2) + CS%utide(i,j)**1))) ustar_h = US%Z_to_m*US%s_to_T*fluxes%ustar_shelf(i,j) - if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then - state%taux_shelf(i,j) = ustar_h*ustar_h*CS%Rho0*Isqrt2 - state%tauy_shelf(i,j) = state%taux_shelf(i,j) - endif + ! I think that the following can be deleted without causing any problems. + ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then + ! ! These arrays are supposed to be stress components at C-grid points, which is + ! ! inconsistent with what is coded up here. + ! state%taux_shelf(i,j) = ustar_h*ustar_h*CS%Rho0*Isqrt2 + ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) + ! endif ! Estimate the neutral ocean boundary layer thickness as the minimum of the ! reported ocean mixed layer thickness and the neutral Ekman depth. @@ -913,15 +919,14 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! vertical decay scale. if (CS%debug) then - if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then + if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then call uvchksum("tau[xy]_shelf", state%taux_shelf, state%tauy_shelf, & G%HI, haloshift=0) endif endif - if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then + if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) - endif ! GMM: melting is computed using ustar_shelf (and not ustar), which has already ! been passed, I so believe we do not need to update fluxes%ustar. ! Irho0 = 1.0 / CS%Rho0 @@ -941,6 +946,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! fluxes%ustar(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s*sqrt(Irho0 * sqrt(taux2 + tauy2))) ! endif ; enddo ; enddo + endif if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then do j=jsd,jed ; do i=isd,ied diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index d9743d2240..51884cb487 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1151,15 +1151,17 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym "forces%frac_shelf_v is associated, but the other is not.") if (associated(forces%frac_shelf_u)) then - ! This configuration has ice shelves, and the appropriate variables need to - ! be allocated. + ! This configuration has ice shelves, and the appropriate variables need to be + ! allocated. If the arrays have already been allocated, these calls do nothing. call safe_alloc_ptr(visc%tauy_shelf, G%isd, G%ied, G%JsdB, G%JedB) call safe_alloc_ptr(visc%tbl_thick_shelf_u, G%IsdB, G%IedB, G%jsd, G%jed) call safe_alloc_ptr(visc%tbl_thick_shelf_v, G%isd, G%ied, G%JsdB, G%JedB) call safe_alloc_ptr(visc%kv_tbl_shelf_u, G%IsdB, G%IedB, G%jsd, G%jed) call safe_alloc_ptr(visc%kv_tbl_shelf_v, G%isd, G%ied, G%JsdB, G%JedB) + call safe_alloc_ptr(visc%taux_shelf, G%IsdB, G%IedB, G%jsd, G%jed) + call safe_alloc_ptr(visc%tauy_shelf, G%isd, G%ied, G%JsdB, G%JedB) - ! With a linear drag law, the friction velocity is already known. + ! With a linear drag law under shelves, the friction velocity is already known. ! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 8f9b694853..e7303e54f7 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -187,7 +187,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. real :: dt_Rho0 ! The time step divided by the mean density [T H Z-1 R-1 ~> s m3 kg-1 or s]. - real :: Rho0 ! A density used to convert drag laws into stress in Pa [kg m-3]. real :: dt_Z_to_H ! The time step times the conversion from Z to the ! units of thickness - [T H Z-1 ~> s or s kg m-3]. real :: h_neglect ! A thickness that is so small it is usually lost @@ -215,7 +214,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS endif dt_Rho0 = dt_in_T / GV%H_to_RZ dt_Z_to_H = dt_in_T*GV%Z_to_H - Rho0 = US%R_to_kg_m3*GV%Rho0 h_neglect = GV%H_subroundoff Idt = 1.0 / dt_in_T @@ -320,15 +318,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS enddo ; enddo ; endif if (associated(visc%taux_shelf)) then ; do I=Isq,Ieq - visc%taux_shelf(I,j) = -Rho0*US%L_T2_to_m_s2*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? + visc%taux_shelf(I,j) = -GV%Rho0*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? enddo ; endif if (PRESENT(taux_bot)) then do I=Isq,Ieq - taux_bot(I,j) = US%kg_m3_to_R*Rho0 * (u(I,j,nz)*CS%a_u(I,j,nz+1)) + taux_bot(I,j) = GV%Rho0 * (u(I,j,nz)*CS%a_u(I,j,nz+1)) enddo if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq - taux_bot(I,j) = taux_bot(I,j) + US%kg_m3_to_R*Rho0 * (Ray(I,k)*u(I,j,k)) + taux_bot(I,j) = taux_bot(I,j) + GV%Rho0 * (Ray(I,k)*u(I,j,k)) enddo ; enddo ; endif endif @@ -401,15 +399,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS enddo ; enddo ; endif if (associated(visc%tauy_shelf)) then ; do i=is,ie - visc%tauy_shelf(i,J) = -Rho0*US%L_T2_to_m_s2*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? + visc%tauy_shelf(i,J) = -GV%Rho0*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? enddo ; endif if (present(tauy_bot)) then do i=is,ie - tauy_bot(i,J) = US%kg_m3_to_R*Rho0 * (v(i,J,nz)*CS%a_v(i,J,nz+1)) + tauy_bot(i,J) = GV%Rho0 * (v(i,J,nz)*CS%a_v(i,J,nz+1)) enddo if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie - tauy_bot(i,J) = tauy_bot(i,J) + US%kg_m3_to_R*Rho0 * (Ray(i,k)*v(i,J,k)) + tauy_bot(i,J) = tauy_bot(i,J) + GV%Rho0 * (Ray(i,k)*v(i,J,k)) enddo ; enddo ; endif endif From 1f9144f9b81b232a2e842b3b9f49dd8d1010d48f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 4 Oct 2019 18:07:14 -0400 Subject: [PATCH 154/259] TC4 integration into test suite This patch renames the tc4 test to activate it in the test suite. It also modifies the Makefile to build the input field test scripts. It also modifies the Python build scripts to be PEP8-conformant. We temporarily disable tc4 in the restart tests, since they currently fail. This needs to be addressed before we can merge this into the main branch. The patch does not enable the necessary Python modules for running on Travis, that will also be addressed later. --- .testing/Makefile | 19 +++---- .testing/_tc4/build_data.py | 68 ------------------------ .testing/_tc4/build_grid.py | 75 --------------------------- .testing/_tc4/input.nml | 27 ---------- .testing/{_tc4 => tc4}/MOM_input | 3 ++ .testing/{_tc4 => tc4}/MOM_override | 0 .testing/tc4/build_data.py | 80 +++++++++++++++++++++++++++++ .testing/tc4/build_grid.py | 76 +++++++++++++++++++++++++++ .testing/{_tc4 => tc4}/diag_table | 0 .testing/tc4/input.nml | 18 +++++++ 10 files changed, 187 insertions(+), 179 deletions(-) delete mode 100644 .testing/_tc4/build_data.py delete mode 100644 .testing/_tc4/build_grid.py delete mode 100644 .testing/_tc4/input.nml rename .testing/{_tc4 => tc4}/MOM_input (99%) rename .testing/{_tc4 => tc4}/MOM_override (100%) create mode 100644 .testing/tc4/build_data.py create mode 100644 .testing/tc4/build_grid.py rename .testing/{_tc4 => tc4}/diag_table (100%) create mode 100644 .testing/tc4/input.nml diff --git a/.testing/Makefile b/.testing/Makefile index 0cd5454e3d..650ae14324 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -169,7 +169,7 @@ test: $(foreach t,$(TESTS),test.$(t)) test.regressions: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) test.grids: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(c).grid $(c).grid.diag) test.layouts: $(foreach c,$(CONFIGS),$(c).layout $(c).layout.diag) -test.restarts: $(foreach c,$(CONFIGS),$(c).restart) +test.restarts: $(foreach c,$(filter-out tc4,$(CONFIGS)),$(c).restart) test.repros: $(foreach c,$(CONFIGS),$(c).repro $(c).repro.diag) test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) @@ -225,6 +225,7 @@ results/%/ocean.stats.$(1): ../build/$(2)/MOM6 if [ $(3) ]; then find ../build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p work/$$*/$(1) cp -rL $$*/* work/$$*/$(1) + cd work/$$*/$(1) && if [ -f Makefile ]; then make; fi mkdir -p work/$$*/$(1)/RESTART echo $(4) > work/$$*/$(1)/MOM_override cd work/$$*/$(1) && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> debug.out > std.out \ @@ -259,6 +260,7 @@ results/%/ocean.stats.restart: ../build/symmetric/MOM6 rm -rf work/$*/restart mkdir -p work/$*/restart cp -rL $*/* work/$*/restart + cd work/$*/restart && if [ -f Makefile ]; then make; fi mkdir -p work/$*/restart/RESTART # Generate the half-period input namelist # TODO: Assumes runtime set by DAYMAX, will fail if set by input.nml @@ -268,20 +270,19 @@ results/%/ocean.stats.restart: ../build/symmetric/MOM6 && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ && printf -v timeunit_int "%.f" "$${timeunit}" \ && halfperiod=$$(printf "%.f" $$(bc <<< "scale=10; 0.5 * $${daymax} * $${timeunit_int}")) \ - && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml \ - && echo $${daymax} $${timeunit} + && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml # Run the first half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug.out > std.out \ - || ! sed 's/^/$*.restart1: /' std.out debug.out \ - && sed 's/^/$*.restart1: /' std.out + cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug1.out > std1.out \ + || ! sed 's/^/$*.restart1: /' std1.out debug1.out \ + && sed 's/^/$*.restart1: /' std1.out # Setup the next inputs cd work/$*/restart && rm -rf INPUT && mv RESTART INPUT mkdir work/$*/restart/RESTART cd work/$*/restart && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug.out > std.out \ - || ! sed 's/^/$*.restart2: /' std.out debug.out \ - && sed 's/^/$*.restart2: /' std.out + cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug2.out > std2.out \ + || ! sed 's/^/$*.restart2: /' std2.out debug2.out \ + && sed 's/^/$*.restart2: /' std2.out # Archive the results and cleanup mkdir -p $(@D) cp work/$*/restart/ocean.stats $@ diff --git a/.testing/_tc4/build_data.py b/.testing/_tc4/build_data.py deleted file mode 100644 index 904db77c7a..0000000000 --- a/.testing/_tc4/build_data.py +++ /dev/null @@ -1,68 +0,0 @@ -import netCDF4 as nc -import numpy as np - -x=nc.Dataset('ocean_hgrid.nc').variables['x'][1::2,1::2] -y=nc.Dataset('ocean_hgrid.nc').variables['y'][1::2,1::2] -zbot=nc.Dataset('topog.nc').variables['depth'][:] -zbot0=zbot.max() - -def t_fc(x,y,z,radius=5.0,tmag=1.0): # a radially symmetric anomaly in the center of the domain. units are meters and degC - ny,nx=x.shape;nz=z.shape[0] - x0=x[int(ny/2),int(nx/2)];y0=y[int(ny/2),int(nx/2)] - tl=np.zeros((nz,ny,nx)) - zb=z[-1] - if len(z)>1: - zd=z/zb - else: - zd=[0.] - for k in np.arange(len(zd)): - r=np.sqrt((x-x0)**2.+(y-y0)**2.) - tl[k,:]=tl[k,:]+(1.0-np.minimum(r/radius,1.0))*tmag*(1.0-zd[k]) - return tl - -ny,nx = x.shape -nz=10;z=(np.arange(nz)*zbot0)/nz - -temp=t_fc(x,y,z) -salt=np.zeros(temp.shape)+35.0 -fl=nc.Dataset('temp_salt_ic.nc','w',format='NETCDF3_CLASSIC') -fl.createDimension('lon',nx) -fl.createDimension('lat',ny) -fl.createDimension('depth',nz) -fl.createDimension('Time',None) -zv=fl.createVariable('depth','f8',('depth')) -lonv=fl.createVariable('lon','f8',('lon')) -latv=fl.createVariable('lat','f8',('lat')) -timev=fl.createVariable('Time','f8',('Time')) -timev.calendar='noleap' -timev.units='days since 0001-01-01 00:00:00.0' -timev.modulo=' ' -tv=fl.createVariable('ptemp','f8',('Time','depth','lat','lon'),fill_value=-1.e20) -sv=fl.createVariable('salt','f8',('Time','depth','lat','lon'),fill_value=-1.e20) -tv[:]=temp[np.newaxis,:] -sv[:]=salt[np.newaxis,:] -zv[:]=z -lonv[:]=x[0,:] -latv[:]=y[:,0] -timev[0]=0. -fl.sync() -fl.close() - - -# Make Sponge forcing file -dampTime=20.0 # days -secDays=8.64e4 -fl=nc.Dataset('sponge.nc','w',format='NETCDF3_CLASSIC') -fl.createDimension('lon',nx) -fl.createDimension('lat',ny) -lonv=fl.createVariable('lon','f8',('lon')) -latv=fl.createVariable('lat','f8',('lat')) -spv=fl.createVariable('Idamp','f8',('lat','lon'),fill_value=-1.e20) -Idamp=np.zeros((ny,nx)) -if dampTime>0.: - Idamp=0.0+1.0/(dampTime*secDays) -spv[:]=Idamp -lonv[:]=x[0,:] -latv[:]=y[:,0] -fl.sync() -fl.close() diff --git a/.testing/_tc4/build_grid.py b/.testing/_tc4/build_grid.py deleted file mode 100644 index 8187e98144..0000000000 --- a/.testing/_tc4/build_grid.py +++ /dev/null @@ -1,75 +0,0 @@ -import netCDF4 as nc -from netCDF4 import stringtochar -import numpy as np - - -nx=14;ny=10 # grid size -depth0=100. #uniform depth -ds=0.01 # grid resolution at the equator in degrees -Re=6.378e6 # Radius of earth - -topo_=np.zeros((ny,nx))+depth0 -f_topo=nc.Dataset('topog.nc','w',format='NETCDF3_CLASSIC') -ny,nx=topo_.shape -f_topo.createDimension('ny',ny) -f_topo.createDimension('nx',nx) -f_topo.createDimension('ntiles',1) -f_topo.createVariable('depth','f8',('ny','nx')) -f_topo.createVariable('h2','f8',('ny','nx')) -f_topo.variables['depth'][:]=topo_ -f_topo.sync() -f_topo.close() - -x_=np.arange(0,2*nx+1)*ds # units are degrees E -y_=np.arange(0,2*ny+1)*ds # units are degrees N -x,y=np.meshgrid(x_,y_) - -dx=np.zeros((2*ny+1,2*nx)) -dy=np.zeros((2*ny,2*nx+1)) -rad_deg=np.pi/180. -dx[:]=rad_deg*Re*(x[:,1:]-x[:,0:-1])*np.cos(0.5*rad_deg*(y[:,0:-1]+y[:,1:])) -dy[:]=rad_deg*Re*(y[1:,:]-y[0:-1,:]) - -f_sg=nc.Dataset('ocean_hgrid.nc','w',format='NETCDF3_CLASSIC') -f_sg.createDimension('ny',ny*2) -f_sg.createDimension('nx',nx*2) -f_sg.createDimension('nyp',ny*2+1) -f_sg.createDimension('nxp',nx*2+1) -f_sg.createDimension('string',5) -f_sg.createVariable('y','f8',('nyp','nxp')) -f_sg.createVariable('x','f8',('nyp','nxp')) -dyv=f_sg.createVariable('dy','f8',('ny','nxp')) -dxv=f_sg.createVariable('dx','f8',('nyp','nx')) -areav=f_sg.createVariable('area','f8',('ny','nx')) -dxv.units='m' -dyv.units='m' -areav.units='m2' -f_sg.createVariable('angle_dx','f8',('nyp','nxp')) -f_sg.createVariable('tile','S1',('string')) -f_sg.variables['y'].units='degrees' -f_sg.variables['x'].units='degrees' -f_sg.variables['dy'].units='meters' -f_sg.variables['dx'].units='meters' -f_sg.variables['area'].units='m2' -f_sg.variables['angle_dx'].units='degrees' -f_sg.variables['y'][:]=y -f_sg.variables['x'][:]=x -f_sg.variables['dx'][:]=dx -f_sg.variables['dy'][:]=dy -#Compute the area bounded by lines of constant -#latitude-longitud on a sphere in m2. -dlon=x_[1:]-x_[:-1] -dlon=np.tile(dlon[np.newaxis,:],(2*ny,1)) -y1_=y_[:-1] -y1_=y1_[:,np.newaxis]*rad_deg -y2_=y_[1:] -y2_=y2_[:,np.newaxis]*rad_deg -y1_=np.tile(y1_,(1,2*nx)) -y2_=np.tile(y2_,(1,2*nx)) -area=(rad_deg*Re*Re)*(np.sin(y2_)-np.sin(y1_)) * dlon -f_sg.variables['area'][:]=area -f_sg.variables['angle_dx'][:]=0. -str_=stringtochar(np.array(['tile1'],dtype='S5')) -f_sg.variables['tile'][:] = str_ -f_sg.sync() -f_sg.close() diff --git a/.testing/_tc4/input.nml b/.testing/_tc4/input.nml deleted file mode 100644 index 29918fbdee..0000000000 --- a/.testing/_tc4/input.nml +++ /dev/null @@ -1,27 +0,0 @@ - &MOM_input_nml - output_directory = './', - input_filename = 'n' - restart_input_dir = 'INPUT/', - restart_output_dir = 'RESTART/', - parameter_filename = 'MOM_input', - 'MOM_override' / - - &diag_manager_nml - flush_nc_files = .true. - / - - &fms_nml - domains_stack_size = 710000, - stack_size = 0 / - - &ocean_domains_nml - / - - &ocean_solo_nml - months = 0 - date_init = 1,1,1,0,0,0 - hours = 0 - minutes = 0 - seconds = 0 - calendar = 'julian' / - diff --git a/.testing/_tc4/MOM_input b/.testing/tc4/MOM_input similarity index 99% rename from .testing/_tc4/MOM_input rename to .testing/tc4/MOM_input index da0e887a6a..456783af88 100644 --- a/.testing/_tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -397,3 +397,6 @@ MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 ! processors used. ! === module MOM_file_parser === + +DIAG_AS_CHKSUM = True +DEBUG = True diff --git a/.testing/_tc4/MOM_override b/.testing/tc4/MOM_override similarity index 100% rename from .testing/_tc4/MOM_override rename to .testing/tc4/MOM_override diff --git a/.testing/tc4/build_data.py b/.testing/tc4/build_data.py new file mode 100644 index 0000000000..50f45ce9f1 --- /dev/null +++ b/.testing/tc4/build_data.py @@ -0,0 +1,80 @@ +import netCDF4 as nc +import numpy as np + +x = nc.Dataset('ocean_hgrid.nc').variables['x'][1::2, 1::2] +y = nc.Dataset('ocean_hgrid.nc').variables['y'][1::2, 1::2] +zbot = nc.Dataset('topog.nc').variables['depth'][:] +zbot0 = zbot.max() + + +def t_fc(x, y, z, radius=5.0, tmag=1.0): + """a radially symmetric anomaly in the center of the domain. + units are meters and degC. + """ + ny, nx = x.shape + nz = z.shape[0] + + x0 = x[int(ny/2), int(nx/2)] + y0 = y[int(ny/2), int(nx/2)] + + tl = np.zeros((nz, ny, nx)) + zb = z[-1] + if len(z) > 1: + zd = z / zb + else: + zd = [0.] + for k in np.arange(len(zd)): + r = np.sqrt((x - x0)**2 + (y - y0)**2) + tl[k, :] += (1.0 - np.minimum(r / radius, 1.0)) * tmag * (1.0 - zd[k]) + return tl + + +ny, nx = x.shape +nz = 10 +z = (np.arange(nz) * zbot0) / nz + +temp = t_fc(x, y, z) +salt = np.zeros(temp.shape)+35.0 +fl = nc.Dataset('temp_salt_ic.nc', 'w', format='NETCDF3_CLASSIC') +fl.createDimension('lon', nx) +fl.createDimension('lat', ny) +fl.createDimension('depth', nz) +fl.createDimension('Time', None) +zv = fl.createVariable('depth', 'f8', ('depth')) +lonv = fl.createVariable('lon', 'f8', ('lon')) +latv = fl.createVariable('lat', 'f8', ('lat')) +timev = fl.createVariable('Time', 'f8', ('Time')) +timev.calendar = 'noleap' +timev.units = 'days since 0001-01-01 00:00:00.0' +timev.modulo = ' ' +tv = fl.createVariable('ptemp', 'f8', ('Time', 'depth', 'lat', 'lon'), + fill_value=-1.e20) +sv = fl.createVariable('salt', 'f8', ('Time', 'depth', 'lat', 'lon'), + fill_value=-1.e20) +tv[:] = temp[np.newaxis, :] +sv[:] = salt[np.newaxis, :] +zv[:] = z +lonv[:] = x[0, :] +latv[:] = y[:, 0] +timev[0] = 0. +fl.sync() +fl.close() + + +# Make Sponge forcing file +dampTime = 20.0 # days +secDays = 8.64e4 +fl = nc.Dataset('sponge.nc', 'w', format='NETCDF3_CLASSIC') +fl.createDimension('lon', nx) +fl.createDimension('lat', ny) +lonv = fl.createVariable('lon', 'f8', ('lon')) +latv = fl.createVariable('lat', 'f8', ('lat')) +spv = fl.createVariable('Idamp', 'f8', ('lat', 'lon'), fill_value=-1.e20) +Idamp = np.zeros((ny, nx)) +if dampTime > 0.: + Idamp = 0.0 + 1.0 / (dampTime * secDays) +spv[:] = Idamp +lonv[:] = x[0, :] +latv[:] = y[:, 0] +fl.sync() +fl.close() diff --git a/.testing/tc4/build_grid.py b/.testing/tc4/build_grid.py new file mode 100644 index 0000000000..7f1be74efd --- /dev/null +++ b/.testing/tc4/build_grid.py @@ -0,0 +1,76 @@ +import netCDF4 as nc +from netCDF4 import stringtochar +import numpy as np + +nx, ny = 14, 10 # Grid size +depth0 = 100. # Uniform depth +ds = 0.01 # grid resolution at the equator in degrees +Re = 6.378e6 # Radius of earth + +topo_ = np.zeros((ny, nx)) + depth0 +f_topo = nc.Dataset('topog.nc', 'w', format='NETCDF3_CLASSIC') +ny, nx = topo_.shape +f_topo.createDimension('ny', ny) +f_topo.createDimension('nx', nx) +f_topo.createDimension('ntiles', 1) +f_topo.createVariable('depth', 'f8', ('ny', 'nx')) +f_topo.createVariable('h2', 'f8', ('ny', 'nx')) +f_topo.variables['depth'][:] = topo_ +f_topo.sync() +f_topo.close() + +x_ = np.arange(0, 2*nx + 1) * ds # units are degrees E +y_ = np.arange(0, 2*ny + 1) * ds # units are degrees N +x, y = np.meshgrid(x_, y_) + +dx = np.zeros((2*ny + 1, 2*nx)) +dy = np.zeros((2*ny, 2*nx + 1)) +rad_deg = np.pi / 180. +dx[:] = (rad_deg * Re * (x[:, 1:] - x[:, 0:-1]) + * np.cos(0.5*rad_deg*(y[:, 0:-1] + y[:, 1:]))) +dy[:] = rad_deg * Re * (y[1:, :] - y[0:-1, :]) + +f_sg = nc.Dataset('ocean_hgrid.nc', 'w', format='NETCDF3_CLASSIC') +f_sg.createDimension('ny', 2*ny) +f_sg.createDimension('nx', 2*nx) +f_sg.createDimension('nyp', 2*ny + 1) +f_sg.createDimension('nxp', 2*nx + 1) +f_sg.createDimension('string', 5) +f_sg.createVariable('y', 'f8', ('nyp', 'nxp')) +f_sg.createVariable('x', 'f8', ('nyp', 'nxp')) +dyv = f_sg.createVariable('dy', 'f8', ('ny', 'nxp')) +dxv = f_sg.createVariable('dx', 'f8', ('nyp', 'nx')) +areav = f_sg.createVariable('area', 'f8', ('ny', 'nx')) +dxv.units = 'm' +dyv.units = 'm' +areav.units = 'm2' +f_sg.createVariable('angle_dx', 'f8', ('nyp', 'nxp')) +f_sg.createVariable('tile', 'S1', ('string')) +f_sg.variables['y'].units = 'degrees' +f_sg.variables['x'].units = 'degrees' +f_sg.variables['dy'].units = 'meters' +f_sg.variables['dx'].units = 'meters' +f_sg.variables['area'].units = 'm2' +f_sg.variables['angle_dx'].units = 'degrees' +f_sg.variables['y'][:] = y +f_sg.variables['x'][:] = x +f_sg.variables['dx'][:] = dx +f_sg.variables['dy'][:] = dy + +# Compute the area bounded by lines of constant +# latitude-longitud on a sphere in m2. +dlon = x_[1:] - x_[:-1] +dlon = np.tile(dlon[np.newaxis, :], (2*ny, 1)) +y1_ = y_[:-1] +y1_ = y1_[:, np.newaxis]*rad_deg +y2_ = y_[1:] +y2_ = y2_[:, np.newaxis]*rad_deg +y1_ = np.tile(y1_, (1, 2*nx)) +y2_ = np.tile(y2_, (1, 2*nx)) +area = rad_deg * Re * Re * (np.sin(y2_) - np.sin(y1_)) * dlon +f_sg.variables['area'][:] = area +f_sg.variables['angle_dx'][:] = 0. +str_ = stringtochar(np.array(['tile1'], dtype='S5')) +f_sg.variables['tile'][:] = str_ +f_sg.sync() +f_sg.close() diff --git a/.testing/_tc4/diag_table b/.testing/tc4/diag_table similarity index 100% rename from .testing/_tc4/diag_table rename to .testing/tc4/diag_table diff --git a/.testing/tc4/input.nml b/.testing/tc4/input.nml new file mode 100644 index 0000000000..0b30a7a5a6 --- /dev/null +++ b/.testing/tc4/input.nml @@ -0,0 +1,18 @@ +&mom_input_nml + output_directory = './' + input_filename = 'n' + restart_input_dir = 'INPUT/' + restart_output_dir = 'RESTART/' + parameter_filename = + 'MOM_input', + 'MOM_override', +/ + +&diag_manager_nml + flush_nc_files = .true. +/ + +&fms_nml + domains_stack_size = 710000 + stack_size = 0 +/ From 34193e964a7f7b4190c7b4f6e27f2d6b107e1ceb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 18:59:15 -0400 Subject: [PATCH 155/259] +Added scale arguments in MOM_spatial_means Added optional scale arguments to all of the functions and subroutines in MOM_spatial_means to facilitate rescaling the variables being averaged into mks units for use with the reproducing sums. The return values are multiplied by scale, except for adjust_mean_to_zero, for which the input and output arrays have the same scaling. All answers are bitwise identical. --- src/framework/MOM_spatial_means.F90 | 74 ++++++++++++++++++++--------- 1 file changed, 52 insertions(+), 22 deletions(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 5a84ca0001..829afb851f 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -25,60 +25,72 @@ module MOM_spatial_means contains !> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean(var,G) +function global_area_mean(var, G, scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average + real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_mean + real :: scalefac ! An overall scaling factor for the areas and variable. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie - tmpForSumming(i,j) = var(i,j) * (G%US%L_to_m**2 * G%areaT(i,j) * G%mask2dT(i,j)) + tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo global_area_mean = reproducing_sum(tmpForSumming) * (G%US%m_to_L**2 * G%IareaT_global) end function global_area_mean !> Return the global area integral of a variable. This uses reproducing sums. -function global_area_integral(var,G) +function global_area_integral(var, G, scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to integrate + real, optional, intent(in) :: scale !< A rescaling factor for the variable real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_integral + real :: scalefac ! An overall scaling factor for the areas and variable. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + tmpForSumming(:,:) = 0. do j=js,je ; do i=is, ie - tmpForSumming(i,j) = var(i,j) * (G%US%L_to_m**2 * G%areaT(i,j) * G%mask2dT(i,j)) + tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo global_area_integral = reproducing_sum(tmpForSumming) end function global_area_integral !> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. -function global_layer_mean(var, h, G, GV) +function global_layer_mean(var, h, G, GV, scale) 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(in) :: var !< The variable to average real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, optional, intent(in) :: scale !< A rescaling factor for the variable real, dimension(SZK_(GV)) :: global_layer_mean real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: tmpForSumming, weight real, dimension(SZK_(GV)) :: scalarij, weightij real, dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar + real :: scalefac ! A scaling factor for the variable. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + scalefac = 1.0 ; if (present(scale)) scalefac = scale tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie weight(i,j,k) = (GV%H_to_m * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) - tmpForSumming(i,j,k) = var(i,j,k) * weight(i,j,k) + tmpForSumming(i,j,k) = scalefac * var(i,j,k) * weight(i,j,k) enddo ; enddo ; enddo global_temp_scalar = reproducing_sum(tmpForSumming,sums=scalarij) @@ -91,25 +103,28 @@ function global_layer_mean(var, h, G, GV) end function global_layer_mean !> Find the global thickness-weighted mean of a variable. This uses reproducing sums. -function global_volume_mean(var, h, G, GV) +function global_volume_mean(var, h, G, GV, scale) 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(in) :: var !< The variable being averaged real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, optional, intent(in) :: scale !< A rescaling factor for the variable real :: global_volume_mean !< The thickness-weighted average of var + real :: scalefac ! A scaling factor for the variable. real :: weight_here real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming, sum_weight integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + scalefac = 1.0 ; if (present(scale)) scalefac = scale tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie weight_here = (GV%H_to_m * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) - tmpForSumming(i,j) = tmpForSumming(i,j) + var(i,j,k) * weight_here + tmpForSumming(i,j) = tmpForSumming(i,j) + scalefac * var(i,j,k) * weight_here sum_weight(i,j) = sum_weight(i,j) + weight_here enddo ; enddo ; enddo global_volume_mean = (reproducing_sum(tmpForSumming)) / & @@ -119,7 +134,7 @@ end function global_volume_mean !> Find the global mass-weighted integral of a variable. This uses reproducing sums. -function global_mass_integral(h, G, GV, var, on_PE_only) +function global_mass_integral(h, G, GV, var, on_PE_only, scale) 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)), & @@ -128,25 +143,28 @@ function global_mass_integral(h, G, GV, var, on_PE_only) optional, intent(in) :: var !< The variable being integrated logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only !! done on the local PE, and it is _not_ order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable real :: global_mass_integral !< The mass-weighted integral of var (or 1) in !! kg times the units of var real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming + real :: scalefac ! An overall scaling factor for the areas and variable. logical :: global_sum integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale tmpForSumming(:,:) = 0.0 if (present(var)) then do k=1,nz ; do j=js,je ; do i=is,ie tmpForSumming(i,j) = tmpForSumming(i,j) + var(i,j,k) * & - ((GV%H_to_kg_m2 * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j))) + ((GV%H_to_kg_m2 * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) enddo ; enddo ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie tmpForSumming(i,j) = tmpForSumming(i,j) + & - ((GV%H_to_kg_m2 * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j))) + ((GV%H_to_kg_m2 * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) enddo ; enddo ; enddo endif global_sum = .true. ; if (present(on_PE_only)) global_sum = .not.on_PE_only @@ -164,15 +182,17 @@ end function global_mass_integral !> Determine the global mean of a field along rows of constant i, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_i_mean(array, i_mean, G, mask) +subroutine global_i_mean(array, i_mean, G, mask, scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: mask !< An array used for weighting the i-mean + real, optional, intent(in) :: scale !< A rescaling factor for the variable ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum + real :: scalefac ! A scaling factor for the variable. real :: mask_sum_r integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -180,6 +200,7 @@ subroutine global_i_mean(array, i_mean, G, mask) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset + scalefac = 1.0 ; if (present(scale)) scalefac = scale call reset_EFP_overflow_error() allocate(asum(G%jsg:G%jeg)) @@ -191,7 +212,7 @@ subroutine global_i_mean(array, i_mean, G, mask) enddo do i=is,ie ; do j=js,je - asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(array(i,j)*mask(i,j)) + asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)*mask(i,j)) mask_sum(j+jdg_off) = mask_sum(j+jdg_off) + real_to_EFP(mask(i,j)) enddo ; enddo @@ -216,7 +237,7 @@ subroutine global_i_mean(array, i_mean, G, mask) do j=G%jsg,G%jeg ; asum(j) = real_to_EFP(0.0) ; enddo do i=is,ie ; do j=js,je - asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(array(i,j)) + asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)) enddo ; enddo if (query_EFP_overflow_error()) call MOM_error(FATAL, & @@ -238,22 +259,25 @@ end subroutine global_i_mean !> Determine the global mean of a field along rows of constant j, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_j_mean(array, j_mean, G, mask) +subroutine global_j_mean(array, j_mean, G, mask, scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: mask !< An array used for weighting the j-mean + real, optional, intent(in) :: scale !< A rescaling factor for the variable ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum real :: mask_sum_r + real :: scalefac ! A scaling factor for the variable. integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset + scalefac = 1.0 ; if (present(scale)) scalefac = scale call reset_EFP_overflow_error() allocate(asum(G%isg:G%ieg)) @@ -265,7 +289,7 @@ subroutine global_j_mean(array, j_mean, G, mask) enddo do i=is,ie ; do j=js,je - asum(i+idg_off) = asum(i+idg_off) + real_to_EFP(array(i,j)*mask(i,j)) + asum(i+idg_off) = asum(i+idg_off) + real_to_EFP(scalefac*array(i,j)*mask(i,j)) mask_sum(i+idg_off) = mask_sum(i+idg_off) + real_to_EFP(mask(i,j)) enddo ; enddo @@ -290,7 +314,7 @@ subroutine global_j_mean(array, j_mean, G, mask) do i=G%isg,G%ieg ; asum(i) = real_to_EFP(0.0) ; enddo do i=is,ie ; do j=js,je - asum(i+idg_off) = asum(i+idg_off) + real_to_EFP(array(i,j)) + asum(i+idg_off) = asum(i+idg_off) + real_to_EFP(scalefac*array(i,j)) enddo ; enddo if (query_EFP_overflow_error()) call MOM_error(FATAL, & @@ -311,22 +335,28 @@ subroutine global_j_mean(array, j_mean, G, mask) end subroutine global_j_mean !> Adjust 2d array such that area mean is zero without moving the zero contour -subroutine adjust_area_mean_to_zero(array, G, scaling) +subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) type(ocean_grid_type), intent(in) :: G !< Grid structure real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted real, optional, intent(out) :: scaling !< The scaling factor used + real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: posVals, negVals, areaXposVals, areaXnegVals integer :: i,j + real :: scalefac ! A scaling factor for the variable. + real :: I_scalefac ! The Adcroft reciprocal of scalefac real :: areaIntPosVals, areaIntNegVals, posScale, negScale + scalefac = 1.0 ; if (present(unit_scale)) scalefac = unit_scale + I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac + areaXposVals(:,:) = 0. areaXnegVals(:,:) = 0. do j=G%jsc,G%jec ; do i=G%isc,G%iec - posVals(i,j) = max(0., array(i,j)) + posVals(i,j) = max(0., scalefac*array(i,j)) areaXposVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * posVals(i,j) - negVals(i,j) = min(0., array(i,j)) + negVals(i,j) = min(0., scalefac*array(i,j)) areaXnegVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * negVals(i,j) enddo ; enddo @@ -338,12 +368,12 @@ subroutine adjust_area_mean_to_zero(array, G, scaling) if (areaIntPosVals>-areaIntNegVals) then ! Scale down positive values posScale = - areaIntNegVals / areaIntPosVals do j=G%jsc,G%jec ; do i=G%isc,G%iec - array(i,j) = (posScale * posVals(i,j)) + negVals(i,j) + array(i,j) = ((posScale * posVals(i,j)) + negVals(i,j)) * I_scalefac enddo ; enddo elseif (areaIntPosVals<-areaIntNegVals) then ! Scale down negative values negScale = - areaIntPosVals / areaIntNegVals do j=G%jsc,G%jec ; do i=G%isc,G%iec - array(i,j) = posVals(i,j) + (negScale * negVals(i,j)) + array(i,j) = (posVals(i,j) + (negScale * negVals(i,j))) * I_scalefac enddo ; enddo endif endif From dbad998ab2f9ec7158a9e9173c5a0231c83c6745 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Oct 2019 19:26:50 -0400 Subject: [PATCH 156/259] +Rescaled the units of surface mass fluxes Rescaled the units of 7 surface mass flux elements in the forcing type, including lprec, fprec, lrunoff, frunoff, evap, vprec, and seaice_melt. Also added a number of unit_scaling_type arguments to subroutines to enable this rescaling. All answers are bitwise identical, but the units of 7 elements of a widely used public type have changed and there are new subroutine arguments. --- .../MOM_surface_forcing_gfdl.F90 | 37 ++-- config_src/coupled_driver/ocean_model_MOM.F90 | 8 +- .../ice_solo_driver/MOM_surface_forcing.F90 | 23 +-- .../ice_solo_driver/user_surface_forcing.F90 | 27 ++- config_src/mct_driver/mom_ocean_model_mct.F90 | 8 +- .../mct_driver/mom_surface_forcing_mct.F90 | 45 +++-- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 8 +- .../mom_surface_forcing_nuopc.F90 | 41 +++-- .../solo_driver/MESO_surface_forcing.F90 | 4 +- config_src/solo_driver/MOM_driver.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 63 ++++--- .../solo_driver/user_surface_forcing.F90 | 9 +- src/core/MOM.F90 | 2 +- src/core/MOM_forcing_type.F90 | 165 +++++++++--------- src/diagnostics/MOM_sum_output.F90 | 8 +- src/ice_shelf/MOM_ice_shelf.F90 | 6 +- src/ice_shelf/MOM_marine_ice.F90 | 19 +- .../vertical/MOM_bulk_mixed_layer.F90 | 4 +- .../vertical/MOM_diabatic_aux.F90 | 6 +- src/tracer/MOM_generic_tracer.F90 | 8 +- src/user/BFB_surface_forcing.F90 | 5 +- src/user/SCM_CVMix_tests.F90 | 9 +- src/user/dumbbell_surface_forcing.F90 | 8 +- 23 files changed, 281 insertions(+), 234 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 61d9c60d1d..766f2127c6 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -242,6 +242,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc real :: delta_sss ! temporary storage for sss diff from restoring value [ppt] real :: delta_sst ! temporary storage for sst diff from restoring value [degC] + real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling + !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. real :: C_p ! heat capacity of seawater [J degC-1 kg-1] real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. @@ -255,6 +257,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s C_p = fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 @@ -372,19 +375,21 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (US%R_to_kg_m3*CS%Rho0*CS%Flux_const) * & + (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) + call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & + unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(is:ie,js:je) fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif @@ -408,31 +413,31 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc do j=js,je ; do i=is,ie if (associated(IOB%lprec)) then - fluxes%lprec(i,j) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lprec(i,j) = kg_m2_s_conversion * IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%lprec(i-i0,j-j0), G%mask2dT(i,j), i, j, 'lprec', G) endif if (associated(IOB%fprec)) then - fluxes%fprec(i,j) = IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%fprec(i,j) = kg_m2_s_conversion * IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%fprec(i-i0,j-j0), G%mask2dT(i,j), i, j, 'fprec', G) endif if (associated(IOB%q_flux)) then - fluxes%evap(i,j) = - IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%evap(i,j) = - kg_m2_s_conversion * IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%q_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'q_flux', G) endif if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%runoff(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff', G) endif if (associated(IOB%calving)) then - fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%calving(i-i0,j-j0), G%mask2dT(i,j), i, j, 'calving', G) endif @@ -565,7 +570,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc 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)) + & + net_FW(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T* & + (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) ! The following contribution appears to be calculating the volume flux of sea-ice @@ -583,13 +589,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc 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) + & + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * & (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif @@ -611,7 +617,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc if (CS%allow_flux_adjustments) then ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, fluxes) + call apply_flux_adjustments(G, US, CS, Time, fluxes) endif ! Allow for user-written code to alter fluxes after all the above @@ -1086,8 +1092,9 @@ end subroutine extract_IOB_stresses !! - hflx_adj (Heat flux into the ocean [W m-2]) !! - sflx_adj (Salt flux into the ocean [kg salt m-2 s-1]) !! - prcme_adj (Fresh water flux into the ocean [kg m-2 s-1]) -subroutine apply_flux_adjustments(G, CS, Time, fluxes) +subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(forcing), intent(inout) :: fluxes !< Surface fluxes structure @@ -1120,7 +1127,7 @@ subroutine apply_flux_adjustments(G, CS, Time, fluxes) call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) end subroutine apply_flux_adjustments diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index c5d10c7aaf..9982754053 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -520,7 +520,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (OS%use_ice_shelf) & call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & - call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) #ifdef _USE_GENERIC_TRACER @@ -541,7 +541,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (OS%use_ice_shelf) & call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & - call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) @@ -554,7 +554,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! The net mass forcing is not currently used in the MOM6 dynamics solvers, so this is may be unnecessary. if (do_dyn .and. associated(OS%forces%net_mass_src) .and. .not.OS%forces%net_mass_src_set) & - call get_net_mass_forcing(OS%fluxes, OS%grid, OS%forces%net_mass_src) + call get_net_mass_forcing(OS%fluxes, OS%grid, OS%US, OS%forces%net_mass_src) if (OS%use_waves .and. do_thermo) then ! For now, the waves are only updated on the thermodynamics steps, because that is where @@ -654,7 +654,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (OS%fluxes%fluxes_used .and. do_thermo) then 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) + OS%grid, OS%US, OS%diag, OS%forcing_CSp%handles) call disable_averaging(OS%diag) endif diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index f86fc44101..ea3385e88e 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -275,7 +275,7 @@ subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, U if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G) + call set_net_mass_forcing(fluxes, forces, G, US) endif CS%first_call_set_forcing = .false. @@ -670,7 +670,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) temp(:,:), G%Domain, timelevel=time_lev) do j=js,je ; do i=is,ie fluxes%latent(i,j) = -hlv*temp(i,j) - fluxes%evap(i,j) = -temp(i,j) + fluxes%evap(i,j) = -US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo @@ -688,20 +688,20 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%snow_file), "snow", & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev) + fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) call MOM_read_data(trim(CS%inputdir)//trim(CS%precip_file), "precip", & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev) + fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) do j=js,je ; do i=is,ie fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_w", & - temp(:,:), G%Domain, timelevel=time_lev_monthly) + temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) do j=js,je ; do i=is,ie fluxes%lrunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_s", & - temp(:,:), G%Domain, timelevel=time_lev_monthly) + temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) do j=js,je ; do i=is,ie fluxes%frunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo @@ -731,10 +731,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*fluxes%lrunoff(i,j)*sfc_state%SST(i,j) + fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + fluxes%lrunoff(i,j)*sfc_state%SST(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*hlf - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*hlf + fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*hlf + fluxes%latent_frunoff_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*hlf enddo ; enddo endif ! time_lev /= CS%buoy_last_lev_read @@ -745,7 +746,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - ((US%R_to_kg_m3*CS%Rho0)*CS%Flux_const) * & + fluxes%vprec(i,j) = - ((US%m_to_Z*US%T_to_s*CS%Rho0)*CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -878,7 +879,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & ((T_Restore - sfc_state%SST(i,j)) * (((US%R_to_kg_m3*CS%Rho0) * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - ((US%R_to_kg_m3*CS%Rho0)*CS%Flux_const) * & + fluxes%vprec(i,j) = - ((US%m_to_Z*US%T_to_s*CS%Rho0)*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 53ed835af9..28d60c895a 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -79,11 +79,11 @@ module user_surface_forcing ! state variables. logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. real :: Rho0 ! The density used in the Boussinesq - ! approximation [kg m-3]. + ! approximation [R ~> kg m-3]. real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const ! The restoring rate at the surface [m s-1]. real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar [Pa]. + ! that contributes to ustar [R Z L T-1 ~> Pa]. type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. @@ -140,9 +140,9 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! Set the surface friction velocity [Z s-1 ~> m s-1]. ustar is always positive. if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = US%m_to_Z*US%T_to_s * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) enddo ; enddo ; endif end subroutine USER_wind_forcing @@ -174,7 +174,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! (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. +! fluxes are in [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. real :: Temp_restore ! The temperature that is being restored toward [C]. real :: Salin_restore ! The salinity that is being restored toward [ppt] @@ -250,7 +250,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = US%R_to_kg_m3*CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. @@ -259,9 +259,8 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - sfc_state%SSS(i,j)) / & - (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const)) * & + ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else ! When modifying the code, comment out this error message. It is here @@ -270,7 +269,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / (US%R_to_kg_m3*CS%Rho0) do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. @@ -320,10 +319,10 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) + "The background gustiness in the winds.", & + units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 4f1c7d963a..7ae09cf615 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -529,10 +529,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%icebergs_alter_ocean) then if (do_dyn) & - call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + call iceberg_forces(OS%grid, OS%US, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & - call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif @@ -583,7 +583,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) + call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid, OS%US) if (OS%use_waves) then call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) @@ -677,7 +677,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%fluxes%fluxes_used) then 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) + OS%grid, OS%US, OS%diag, OS%forcing_CSp%handles) call disable_averaging(OS%diag) endif diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 7072c406e8..f9489c8a42 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -237,9 +237,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & !! is present, or false (no restoring) otherwise. logical :: restore_sst !< local copy of the argument restore_temp, if it !! is present, or false (no restoring) otherwise. - real :: delta_sss !< temporary storage for sss diff from restoring value + real :: delta_sss !< temporary storage for sss diff from restoring value2 real :: delta_sst !< temporary storage for sst diff from restoring value + real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling + !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. 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. @@ -253,6 +255,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s C_p = fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 @@ -375,19 +378,21 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (US%R_to_kg_m3*CS%Rho0*CS%Flux_const) * & + (US%m_to_Z*US%T_to_s * CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) + call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & + unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(is:ie,js:je) fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) enddo; enddo endif endif @@ -410,28 +415,28 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js,je ; do i=is,ie ! liquid precipitation (rain) if (associated(IOB%lprec)) & - fluxes%lprec(i,j) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lprec(i,j) = kg_m2_s_conversion * IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) ! frozen precipitation (snow) if (associated(IOB%fprec)) & - fluxes%fprec(i,j) = IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%fprec(i,j) = kg_m2_s_conversion * IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) ! evaporation if (associated(IOB%q_flux)) & - fluxes%evap(i,j) = IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%evap(i,j) = kg_m2_s_conversion * IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) ! liquid runoff flux if (associated(IOB%rofl_flux)) then - fluxes%lrunoff(i,j) = IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) end if ! ice runoff flux if (associated(IOB%rofi_flux)) then - fluxes%frunoff(i,j) = IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%calving)) then - fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) end if if (associated(IOB%ustar_berg)) & @@ -467,7 +472,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & - fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * kg_m2_s_conversion * IOB%seaice_melt(i-i0,j-j0) ! latent heat flux (W/m^2) fluxes%latent(i,j) = 0.0 @@ -533,7 +538,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & 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%seaice_melt(i,j)) + & + net_FW(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) @@ -543,13 +549,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & 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) + & + fluxes%vprec(i,j) = fluxes%vprec(i,j) + kg_m2_s_conversion * & (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) enddo; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) enddo; enddo endif endif @@ -560,7 +566,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (CS%allow_flux_adjustments) then ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, fluxes) + call apply_flux_adjustments(G, US, CS, Time, fluxes) endif ! Allow for user-written code to alter fluxes after all the above @@ -865,8 +871,9 @@ end subroutine convert_IOB_to_forces !! - hflx_adj (Heat flux into the ocean, in W m-2) !! - sflx_adj (Salt flux into the ocean, in kg salt m-2 s-1) !! - prcme_adj (Fresh water flux into the ocean, in kg m-2 s-1) -subroutine apply_flux_adjustments(G, CS, Time, fluxes) +subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(forcing), intent(inout) :: fluxes !< Surface fluxes structure @@ -899,7 +906,7 @@ subroutine apply_flux_adjustments(G, CS, Time, fluxes) call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index e04064f672..726ad93ec0 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -526,7 +526,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & - call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif @@ -557,7 +557,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & - call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif @@ -571,7 +571,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & #endif endif call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) + call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid, OS%US) if (OS%use_waves) then call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) @@ -664,7 +664,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%fluxes%fluxes_used) then 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) + OS%grid, US%US, OS%diag, OS%forcing_CSp%handles) call disable_averaging(OS%diag) endif diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 7e56780a36..f81ea561db 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -244,6 +244,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & !! is present, or false (no restoring) otherwise. real :: delta_sss !< temporary storage for sss diff from restoring value real :: delta_sst !< temporary storage for sst diff from restoring value + real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling + !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. 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. @@ -258,6 +260,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s C_p = fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 @@ -387,13 +390,15 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) + call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & + unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(is:ie,js:je) fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif @@ -416,26 +421,26 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js,je ; do i=is,ie if (associated(IOB%lprec)) & - fluxes%lprec(i,j) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lprec(i,j) = kg_m2_s_conversion * IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%fprec)) & - fluxes%fprec(i,j) = IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%fprec(i,j) = kg_m2_s_conversion * IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%q_flux)) & - fluxes%evap(i,j) = IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%evap(i,j) = kg_m2_s_conversion * IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) ! liquid runoff flux if (associated(IOB%rofl_flux)) then - fluxes%lrunoff(i,j) = IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) endif ! ice runoff flux if (associated(IOB%rofi_flux)) then - fluxes%frunoff(i,j) = IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) elseif (associated(IOB%calving)) then - fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) endif if (associated(IOB%ustar_berg)) & @@ -465,7 +470,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & - fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) fluxes%latent(i,j) = 0.0 if (associated(IOB%fprec)) then @@ -527,7 +532,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & 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%seaice_melt(i,j)) + & + net_FW(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) @@ -536,13 +542,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & 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) + & + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * & (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif @@ -554,7 +560,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (CS%allow_flux_adjustments) then ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, fluxes) + call apply_flux_adjustments(G, US, CS, Time, fluxes) endif ! Allow for user-written code to alter fluxes after all the above @@ -862,8 +868,9 @@ end subroutine convert_IOB_to_forces !! - hflx_adj (Heat flux into the ocean, in W m-2) !! - sflx_adj (Salt flux into the ocean, in kg salt m-2 s-1) !! - prcme_adj (Fresh water flux into the ocean, in kg m-2 s-1) -subroutine apply_flux_adjustments(G, CS, Time, fluxes) +subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure type(forcing), intent(inout) :: fluxes !< Surface fluxes structure @@ -896,7 +903,7 @@ subroutine apply_flux_adjustments(G, CS, Time, fluxes) call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) end subroutine apply_flux_adjustments diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index ee3cd36b41..f828513dae 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -142,7 +142,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! 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) = CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s * CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) ! vprec will be set later, if it is needed for salinity restoring. fluxes%vprec(i,j) = 0.0 @@ -176,7 +176,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + fluxes%vprec(i,j) = - (US%kg_m3_to_R*US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index b057e06f9e..a6d6597c0e 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -580,7 +580,7 @@ program MOM_main if (.not. offline_tracer_mode) then if (fluxes%fluxes_used) then call enable_averaging(fluxes%dt_buoy_accum, Time, diag) - call forcing_diagnostics(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, & + call forcing_diagnostics(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, US, & diag, surface_forcing_CSp%handles) call disable_averaging(diag) else diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 101956d283..7224d68d48 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -315,13 +315,13 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US elseif (trim(CS%buoy_config) == "Neverland") then call Neverland_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%Neverland_forcing_CSp) elseif (trim(CS%buoy_config) == "SCM_CVmix_tests") then - call SCM_CVmix_tests_buoyancy_forcing(sfc_state, fluxes, day_center, G, CS%SCM_CVmix_tests_CSp) + call SCM_CVmix_tests_buoyancy_forcing(sfc_state, fluxes, day_center, G, US, CS%SCM_CVmix_tests_CSp) elseif (trim(CS%buoy_config) == "USER") then call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, CS%user_forcing_CSp) elseif (trim(CS%buoy_config) == "BFB") then call BFB_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, 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) + call dumbbell_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, US, 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 @@ -348,7 +348,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G) + call set_net_mass_forcing(fluxes, forces, G, US) endif CS%first_call_set_forcing = .false. @@ -842,12 +842,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) G%Domain, timelevel=time_lev) do j=js,je ; do i=is,ie fluxes%latent(i,j) = -CS%latent_heat_vapor*temp(i,j) - fluxes%evap(i,j) = -temp(i,j) + fluxes%evap(i,j) = -US%kg_m3_to_R*US%m_to_Z*US%T_to_s*temp(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo else call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) endif CS%evap_last_lev = time_lev @@ -902,9 +902,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select call MOM_read_data(CS%snow_file, CS%snow_var, & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev) + fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) call MOM_read_data(CS%rain_file, CS%rain_var, & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev) + fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) if (CS%archaic_OMIP_file) then do j=js,je ; do i=is,ie fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) @@ -919,20 +919,20 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) end select if (CS%archaic_OMIP_file) then call MOM_read_data(CS%runoff_file, CS%lrunoff_var, temp(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) do j=js,je ; do i=is,ie fluxes%lrunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo call MOM_read_data(CS%runoff_file, CS%frunoff_var, temp(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) do j=js,je ; do i=is,ie fluxes%frunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo else call MOM_read_data(CS%runoff_file, CS%lrunoff_var, fluxes%lrunoff(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) call MOM_read_data(CS%runoff_file, CS%frunoff_var, fluxes%frunoff(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) endif CS%runoff_last_lev = time_lev @@ -976,8 +976,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo endif ! time_lev /= CS%buoy_last_lev_read @@ -991,12 +991,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (US%R_to_kg_m3*CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 endif enddo ; enddo else @@ -1089,10 +1089,12 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! note the sign convention do j=js,je ; do i=is,ie - fluxes%evap(i,j) = -fluxes%evap(i,j) ! Normal convention is positive into the ocean - ! but evap is normally a positive quantity in the files - fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) + ! This is dangerous because it is not clear whether the data files have been read! + fluxes%evap(i,j) = -fluxes%evap(i,j) ! Normal convention is positive into the ocean + ! but evap is normally a positive quantity in the files + fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) + fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) + fluxes%evap(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*fluxes%evap(i,j) enddo ; enddo call data_override('OCN', 'sens', fluxes%sens(:,:), day, & @@ -1108,16 +1110,23 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) call data_override('OCN', 'snow', fluxes%fprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s call data_override('OCN', 'rain', fluxes%lprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s call data_override('OCN', 'runoff', fluxes%lrunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s call data_override('OCN', 'calving', fluxes%frunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s + + if (US%kg_m3_to_R*US%m_to_Z*US%T_to_s /= 1.0) then ; do j=js,je ; do i=is,ie + fluxes%lprec(i,j) = fluxes%lprec(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s + fluxes%fprec(i,j) = fluxes%fprec(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s + fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s + fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s + enddo ; enddo ; endif ! Read the SST and SSS fields for damping. if (CS%restorebuoy) then !#CTRL# .or. associated(CS%ctrl_forcing_CSp)) then @@ -1136,7 +1145,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (Rho0_mks*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%Rho0*US%m_to_Z*US%T_to_s*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1180,8 +1189,8 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo @@ -1336,7 +1345,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((T_Restore - sfc_state%SST(i,j)) * ((Rho0_mks * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (Rho0_mks*CS%Flux_const) * & + fluxes%vprec(i,j) = - (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 1afe999e51..1831503f1f 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -123,7 +123,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! (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. +! fluxes are in [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. ! Local variables real :: Temp_restore ! The temperature that is being restored toward [degC]. @@ -172,7 +172,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! 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] + ! Fluxes of fresh water through the surface are in units of [R Z T-1 ~> 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) @@ -211,9 +211,8 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (Rho0_mks*CS%Flux_const)) * & - ((Salin_restore - sfc_state%SSS(i,j)) / & - (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const)) * & + ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else ! When modifying the code, comment out this error message. It is here diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f4ef5a1376..b490311cf2 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -852,7 +852,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! Accumulate the surface fluxes for assessing conservation if (do_thermo .and. fluxes%fluxes_used) & call accumulate_net_input(fluxes, sfc_state, CS%tv, fluxes%dt_buoy_accum, & - G, CS%sum_output_CSp) + G, US, CS%sum_output_CSp) if (MOM_state_is_synchronized(CS)) & call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 2b064a2834..a5e56b9ad1 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -82,13 +82,13 @@ module MOM_forcing_type ! water mass fluxes into the ocean [kg m-2 s-1]; these fluxes impact the ocean mass real, pointer, dimension(:,:) :: & - evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean [kg m-2 s-1] - lprec => NULL(), & !< precipitating liquid water into the ocean [kg m-2 s-1] - fprec => NULL(), & !< precipitating frozen water into the ocean [kg m-2 s-1] - vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring [kg m-2 s-1] - lrunoff => NULL(), & !< liquid river runoff entering ocean [kg m-2 s-1] - frunoff => NULL(), & !< frozen river runoff (calving) entering ocean [kg m-2 s-1] - seaice_melt => NULL(), & !< snow/seaice melt (positive) or formation (negative) [kg m-2 s-1] + evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean [R Z T-1 ~> kg m-2 s-1] + lprec => NULL(), & !< precipitating liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] + fprec => NULL(), & !< precipitating frozen water into the ocean [R Z T-1 ~> kg m-2 s-1] + vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring [R Z T-1 ~> kg m-2 s-1] + lrunoff => NULL(), & !< liquid river runoff entering ocean [R Z T-1 ~> kg m-2 s-1] + frunoff => NULL(), & !< frozen river runoff (calving) entering ocean [R Z T-1 ~> kg m-2 s-1] + seaice_melt => NULL(), & !< snow/seaice melt (positive) or formation (negative) [R Z T-1 ~> kg m-2 s-1] netMassIn => NULL(), & !< Sum of water mass flux out of the ocean [kg m-2 s-1] netMassOut => NULL(), & !< Net water mass flux into of the ocean [kg m-2 s-1] netSalt => NULL() !< Net salt entering the ocean [kgSalt m-2 s-1] @@ -97,7 +97,7 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & heat_content_cond => NULL(), & !< heat content associated with condensating water [W m-2] heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [W m-2] (diagnostic) - heat_content_icemelt => NULL(), & !< heat content associated with snow/seaice melt/formation [W/m^2] + heat_content_icemelt => NULL(), & !< heat content associated with snow/seaice melt/formation [W m-2] heat_content_fprec => NULL(), & !< heat content associated with frozen precip [W m-2] heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [W m-2] heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [W m-2] @@ -509,16 +509,18 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, endif ! net volume/mass of liquid and solid passing through surface boundary fluxes - netMassInOut(i) = dt * (scale * (((((( fluxes%lprec(i,j) & + netMassInOut(i) = dt * (scale * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*& + (((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & + fluxes%lrunoff(i,j) ) & + fluxes%vprec(i,j) ) & + fluxes%seaice_melt(i,j)) & - + fluxes%frunoff(i,j) )) + + fluxes%frunoff(i,j) )) if (do_NMIOr) then ! Repeat the above code w/ dt=1s for legacy reasons - netMassInOut_rate(i) = (scale * (((((( fluxes%lprec(i,j) & + netMassInOut_rate(i) = (scale * US%R_to_kg_m3*US%Z_to_m*US%s_to_T* & + (((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & + fluxes%lrunoff(i,j) ) & @@ -545,25 +547,25 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! evap < 0 means evaporation of water from the ocean, in ! which case heat_content_evap is computed in MOM_diabatic_driver.F90 if (fluxes%evap(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + fluxes%evap(i,j) + netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) ! if (associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA endif ! lprec < 0 means sea ice formation taking water from the ocean. ! smg: we should split the ice melt/formation from the lprec if (fluxes%lprec(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + fluxes%lprec(i,j) + netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) endif ! seaice_melt < 0 means sea ice formation taking water from the ocean. if (fluxes%seaice_melt(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + fluxes%seaice_melt(i,j) + netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) endif ! vprec < 0 means virtual evaporation arising from surface salinity restoring, ! in which case heat_content_vprec is computed in MOM_diabatic_driver.F90. if (fluxes%vprec(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + fluxes%vprec(i,j) + netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) endif netMassOut(i) = dt * scale * netMassOut(i) @@ -603,15 +605,15 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, if (useRiverHeatContent) then ! remove lrunoff*SST here, to counteract its addition elsewhere net_heat(i) = (net_heat(i) + (scale*(dt*J_m2_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & - (GV%kg_m2_to_H * (scale * dt)) * fluxes%lrunoff(i,j) * T(i,1) + (GV%kg_m2_to_H * (scale * dt)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & - ! (GV%kg_m2_to_H * (scale)) * fluxes%lrunoff(i,j) * T(i,1) + ! (GV%kg_m2_to_H * (scale)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & - (I_Cp*fluxes%heat_content_lrunoff(i,j) - fluxes%lrunoff(i,j)*T(i,1)) + (I_Cp*fluxes%heat_content_lrunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j)*T(i,1)) endif endif @@ -620,15 +622,15 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, if (useCalvingHeatContent) then ! remove frunoff*SST here, to counteract its addition elsewhere net_heat(i) = net_heat(i) + (scale*(dt*J_m2_to_H)) * fluxes%heat_content_frunoff(i,j) - & - (GV%kg_m2_to_H * (scale * dt)) * fluxes%frunoff(i,j) * T(i,1) + (GV%kg_m2_to_H * (scale * dt)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. ! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_frunoff(i,j) - & -! (GV%kg_m2_to_H * (scale)) * fluxes%frunoff(i,j) * T(i,1) +! (GV%kg_m2_to_H * (scale)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & - (I_Cp*fluxes%heat_content_frunoff(i,j) - fluxes%frunoff(i,j)*T(i,1)) + (I_Cp*fluxes%heat_content_frunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*T(i,1)) endif endif @@ -730,7 +732,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! wait until MOM_diabatic_driver.F90. if (associated(fluxes%heat_content_lprec)) then if (fluxes%lprec(i,j) > 0.0) then - fluxes%heat_content_lprec(i,j) = fluxes%C_p*fluxes%lprec(i,j)*T(i,1) + fluxes%heat_content_lprec(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j)*T(i,1) else fluxes%heat_content_lprec(i,j) = 0.0 endif @@ -741,7 +743,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! and until we do so fprec is treated like lprec and enters at SST. -AJA if (associated(fluxes%heat_content_fprec)) then if (fluxes%fprec(i,j) > 0.0) then - fluxes%heat_content_fprec(i,j) = fluxes%C_p*fluxes%fprec(i,j)*T(i,1) + fluxes%heat_content_fprec(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*T(i,1) else fluxes%heat_content_fprec(i,j) = 0.0 endif @@ -750,7 +752,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Following lprec and fprec, water flux due to sea ice melt (seaice_melt) enters at SST - GMM if (associated(fluxes%heat_content_icemelt)) then if (fluxes%seaice_melt(i,j) > 0.0) then - fluxes%heat_content_icemelt(i,j) = fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) + fluxes%heat_content_icemelt(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j)*T(i,1) else fluxes%heat_content_icemelt(i,j) = 0.0 endif @@ -761,7 +763,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 if (associated(fluxes%heat_content_vprec)) then if (fluxes%vprec(i,j) > 0.0) then - fluxes%heat_content_vprec(i,j) = fluxes%C_p*fluxes%vprec(i,j)*T(i,1) + fluxes%heat_content_vprec(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j)*T(i,1) else fluxes%heat_content_vprec(i,j) = 0.0 endif @@ -775,7 +777,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Condensation is assumed to drop into the ocean at the SST, just like lprec. if (associated(fluxes%heat_content_cond)) then if (fluxes%evap(i,j) > 0.0) then - fluxes%heat_content_cond(i,j) = fluxes%C_p*fluxes%evap(i,j)*T(i,1) + fluxes%heat_content_cond(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j)*T(i,1) else fluxes%heat_content_cond(i,j) = 0.0 endif @@ -784,14 +786,14 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Liquid runoff enters ocean at SST if land model does not provide runoff heat content. if (.not. useRiverHeatContent) then if (associated(fluxes%lrunoff) .and. associated(fluxes%heat_content_lrunoff)) then - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*fluxes%lrunoff(i,j)*T(i,1) + fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j)*T(i,1) endif endif ! Icebergs enter ocean at SST if land model does not provide calving heat content. if (.not. useCalvingHeatContent) then if (associated(fluxes%frunoff) .and. associated(fluxes%heat_content_frunoff)) then - fluxes%heat_content_frunoff(i,j) = fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) + fluxes%heat_content_frunoff(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*T(i,1) endif endif @@ -1045,15 +1047,16 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%sens)) & call hchksum(fluxes%sens, mesg//" fluxes%sens",G%HI,haloshift=hshift) if (associated(fluxes%evap)) & - call hchksum(fluxes%evap, mesg//" fluxes%evap",G%HI,haloshift=hshift) + call hchksum(fluxes%evap, mesg//" fluxes%evap",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (associated(fluxes%lprec)) & - call hchksum(fluxes%lprec, mesg//" fluxes%lprec",G%HI,haloshift=hshift) + call hchksum(fluxes%lprec, mesg//" fluxes%lprec",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (associated(fluxes%fprec)) & - call hchksum(fluxes%fprec, mesg//" fluxes%fprec",G%HI,haloshift=hshift) + call hchksum(fluxes%fprec, mesg//" fluxes%fprec",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (associated(fluxes%vprec)) & - call hchksum(fluxes%vprec, mesg//" fluxes%vprec",G%HI,haloshift=hshift) + call hchksum(fluxes%vprec, mesg//" fluxes%vprec",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (associated(fluxes%seaice_melt)) & - call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt",G%HI,haloshift=hshift) + call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt",G%HI,haloshift=hshift, & + scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (associated(fluxes%seaice_melt_heat)) & call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat",G%HI,haloshift=hshift) if (associated(fluxes%p_surf)) & @@ -1066,9 +1069,9 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%ustar_tidal)) & call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & - call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff",G%HI,haloshift=hshift) + call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (associated(fluxes%frunoff)) & - call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff",G%HI,haloshift=hshift) + call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (associated(fluxes%heat_content_lrunoff)) & call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff",G%HI,haloshift=hshift) if (associated(fluxes%heat_content_frunoff)) & @@ -1294,12 +1297,14 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Liquid + frozen precipitation into ocean', 'kg m-2 s-1') handles%id_fprec = register_diag_field('ocean_model', 'fprec', diag%axesT1, Time, & - 'Frozen precipitation into ocean', 'kg m-2 s-1', & + 'Frozen precipitation into ocean', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='snowfall_flux', cmor_field_name='prsn', & cmor_standard_name='snowfall_flux', cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea') handles%id_lprec = register_diag_field('ocean_model', 'lprec', diag%axesT1, Time, & - 'Liquid precipitation into ocean', 'kg m-2 s-1', & + 'Liquid precipitation into ocean', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='rainfall_flux', & cmor_field_name='prlq', cmor_standard_name='rainfall_flux', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea') @@ -2095,21 +2100,23 @@ end subroutine set_derived_forcing_fields !> This subroutine determines the net mass source to the ocean from !! a (thermodynamic) forcing type and stores it in a mech_forcing type. -subroutine set_net_mass_forcing(fluxes, forces, G) +subroutine set_net_mass_forcing(fluxes, forces, G, US) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_grid_type), intent(in) :: G !< The ocean grid type if (associated(forces%net_mass_src)) & - call get_net_mass_forcing(fluxes, G, forces%net_mass_src) + call get_net_mass_forcing(fluxes, G, US, forces%net_mass_src) end subroutine set_net_mass_forcing !> This subroutine calculates determines the net mass source to the ocean from !! a (thermodynamic) forcing type and stores it in a provided array. -subroutine get_net_mass_forcing(fluxes, G, net_mass_src) +subroutine get_net_mass_forcing(fluxes, G, US, net_mass_src) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(ocean_grid_type), intent(in) :: G !< The ocean grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_mass_src !< The net mass flux of water into the ocean !! [kg m-2 s-1]. @@ -2118,25 +2125,25 @@ subroutine get_net_mass_forcing(fluxes, G, net_mass_src) net_mass_src(:,:) = 0.0 if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lprec(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) enddo ; enddo ; endif if (associated(fluxes%fprec)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + fluxes%fprec(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j) enddo ; enddo ; endif if (associated(fluxes%vprec)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + fluxes%vprec(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) enddo ; enddo ; endif if (associated(fluxes%lrunoff)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lrunoff(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) enddo ; enddo ; endif if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) enddo ; enddo ; endif if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + fluxes%evap(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) enddo ; enddo ; endif if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + fluxes%seaice_melt(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) enddo ; enddo ; endif end subroutine get_net_mass_forcing @@ -2196,12 +2203,13 @@ end subroutine mech_forcing_diags !> Offer buoyancy forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. -subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) +subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, intent(in) :: dt !< time step type(ocean_grid_type), intent(in) :: G !< grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), intent(in) :: diag !< diagnostic regulator type(forcing_diags), intent(inout) :: handles !< diagnostic ids @@ -2228,14 +2236,15 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_prcme > 0 .or. handles%id_total_prcme > 0 .or. handles%id_prcme_ga > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (associated(fluxes%lprec)) res(i,j) = res(i,j)+fluxes%lprec(i,j) - if (associated(fluxes%fprec)) res(i,j) = res(i,j)+fluxes%fprec(i,j) + if (associated(fluxes%lprec)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) + if (associated(fluxes%fprec)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j) ! fluxes%cond is not needed because it is derived from %evap > 0 - if (associated(fluxes%evap)) res(i,j) = res(i,j)+fluxes%evap(i,j) - if (associated(fluxes%lrunoff)) res(i,j) = res(i,j)+fluxes%lrunoff(i,j) - if (associated(fluxes%frunoff)) res(i,j) = res(i,j)+fluxes%frunoff(i,j) - if (associated(fluxes%vprec)) res(i,j) = res(i,j)+fluxes%vprec(i,j) - if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j)+fluxes%seaice_melt(i,j) + if (associated(fluxes%evap)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) + if (associated(fluxes%lrunoff)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) + if (associated(fluxes%frunoff)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) + if (associated(fluxes%vprec)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) + if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j) + & + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) enddo ; enddo if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) if (handles%id_total_prcme > 0) then @@ -2252,17 +2261,17 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) do j=js,je ; do i=is,ie res(i,j) = 0.0 if (associated(fluxes%lprec)) then - if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) endif if (associated(fluxes%vprec)) then - if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) endif if (associated(fluxes%evap)) then - if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) endif if (associated(fluxes%seaice_melt)) then if (fluxes%seaice_melt(i,j) < 0.0) & - res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) endif enddo ; enddo if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) @@ -2280,25 +2289,25 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) res(i,j) = 0.0 if (associated(fluxes%fprec)) & - res(i,j) = res(i,j) + fluxes%fprec(i,j) + res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j) if (associated(fluxes%lrunoff)) & - res(i,j) = res(i,j) + fluxes%lrunoff(i,j) + res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) if (associated(fluxes%frunoff)) & - res(i,j) = res(i,j) + fluxes%frunoff(i,j) + res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) if (associated(fluxes%lprec)) then - if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) endif if (associated(fluxes%vprec)) then - if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) endif ! fluxes%cond is not needed because it is derived from %evap > 0 if (associated(fluxes%evap)) then - if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) endif if (associated(fluxes%seaice_melt)) then if (fluxes%seaice_melt(i,j) > 0.0) & - res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) + res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) endif enddo ; enddo if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) @@ -2314,17 +2323,17 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) if ((handles%id_total_evap > 0) .and. associated(fluxes%evap)) then - total_transport = global_area_integral(fluxes%evap,G) + total_transport = global_area_integral(fluxes%evap, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_total_evap, total_transport, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then - ave_flux = global_area_mean(fluxes%evap,G) + ave_flux = global_area_mean(fluxes%evap, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_evap_ga, ave_flux, diag) endif if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie - res(i,j) = fluxes%lprec(i,j) + fluxes%fprec(i,j) + res(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T* (fluxes%lprec(i,j) + fluxes%fprec(i,j)) enddo ; enddo if (handles%id_precip > 0) call post_data(handles%id_precip, res, diag) if (handles%id_total_precip > 0) then @@ -2340,11 +2349,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%lprec)) then if (handles%id_lprec > 0) call post_data(handles%id_lprec, fluxes%lprec, diag) if (handles%id_total_lprec > 0) then - total_transport = global_area_integral(fluxes%lprec,G) + total_transport = global_area_integral(fluxes%lprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_total_lprec, total_transport, diag) endif if (handles%id_lprec_ga > 0) then - ave_flux = global_area_mean(fluxes%lprec,G) + ave_flux = global_area_mean(fluxes%lprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_lprec_ga, ave_flux, diag) endif endif @@ -2352,11 +2361,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%fprec)) then if (handles%id_fprec > 0) call post_data(handles%id_fprec, fluxes%fprec, diag) if (handles%id_total_fprec > 0) then - total_transport = global_area_integral(fluxes%fprec,G) + total_transport = global_area_integral(fluxes%fprec ,G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_total_fprec, total_transport, diag) endif if (handles%id_fprec_ga > 0) then - ave_flux = global_area_mean(fluxes%fprec,G) + ave_flux = global_area_mean(fluxes%fprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_fprec_ga, ave_flux, diag) endif endif @@ -2364,11 +2373,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%vprec)) then if (handles%id_vprec > 0) call post_data(handles%id_vprec, fluxes%vprec, diag) if (handles%id_total_vprec > 0) then - total_transport = global_area_integral(fluxes%vprec,G) + total_transport = global_area_integral(fluxes%vprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_total_vprec, total_transport, diag) endif if (handles%id_vprec_ga > 0) then - ave_flux = global_area_mean(fluxes%vprec,G) + ave_flux = global_area_mean(fluxes%vprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_vprec_ga, ave_flux, diag) endif endif @@ -2376,7 +2385,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%lrunoff)) then if (handles%id_lrunoff > 0) call post_data(handles%id_lrunoff, fluxes%lrunoff, diag) if (handles%id_total_lrunoff > 0) then - total_transport = global_area_integral(fluxes%lrunoff,G) + total_transport = global_area_integral(fluxes%lrunoff, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_total_lrunoff, total_transport, diag) endif endif @@ -2384,7 +2393,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%frunoff)) then if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) if (handles%id_total_frunoff > 0) then - total_transport = global_area_integral(fluxes%frunoff,G) + total_transport = global_area_integral(fluxes%frunoff, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_total_frunoff, total_transport, diag) endif endif @@ -2392,7 +2401,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%seaice_melt)) then if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) if (handles%id_total_seaice_melt > 0) then - total_transport = global_area_integral(fluxes%seaice_melt,G) + total_transport = global_area_integral(fluxes%seaice_melt, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call post_data(handles%id_total_seaice_melt, total_transport, diag) endif endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 1a8a9879b3..7bb8ba73e9 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -936,7 +936,7 @@ end subroutine write_energy !> This subroutine accumates the net input of volume, salt and heat, through !! the ocean surface for use in diagnosing conservation. -subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, CS) +subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible !! forcing fields. Unused fields are unallocated. type(surface), intent(in) :: sfc_state !< A structure containing fields that @@ -945,6 +945,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, CS) !! thermodynamic variables. real, intent(in) :: dt !< The amount of time over which to average [s]. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call !! to MOM_sum_output_init. ! Local variables @@ -977,7 +978,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, CS) if (associated(fluxes%evap)) then if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie - FW_in(i,j) = dt*G%US%L_to_m**2*G%areaT(i,j)*(fluxes%evap(i,j) + & + FW_in(i,j) = G%US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*dt*G%areaT(i,j)*(fluxes%evap(i,j) + & (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j)) + & (fluxes%fprec(i,j) + fluxes%frunoff(i,j)))) enddo ; enddo @@ -988,7 +989,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, CS) endif if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie - FW_in(i,j) = FW_in(i,j) + dt * G%US%L_to_m**2*G%areaT(i,j) * fluxes%seaice_melt(i,j) + FW_in(i,j) = FW_in(i,j) + G%US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*dt * & + G%areaT(i,j) * fluxes%seaice_melt(i,j) enddo ; enddo ; endif salt_in(:,:) = 0.0 ; heat_in(:,:) = 0.0 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index ca8f3049ee..76f595ee06 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -967,10 +967,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 if (associated(fluxes%lprec)) then if (ISS%water_flux(i,j) > 0.0) then - fluxes%lprec(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%lprec(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*frac_area*ISS%water_flux(i,j)*CS%flux_factor else fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%evap(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*frac_area*ISS%water_flux(i,j)*CS%flux_factor endif endif @@ -1061,6 +1061,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) + ! Rescale fluxes%vprec to the proper units. + fluxes%vprec(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s * fluxes%vprec(i,j) endif enddo ; enddo diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 16b543387d..4042681803 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -15,6 +15,7 @@ module MOM_marine_ice use MOM_forcing_type, only : forcing, mech_forcing use MOM_grid, only : ocean_grid_type use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface implicit none ; private @@ -102,9 +103,10 @@ end subroutine iceberg_forces !> iceberg_fluxes adds ice-area-coverage and modifies various !! thermodynamic fluxes due to the presence of icebergs. -subroutine iceberg_fluxes(G, fluxes, use_ice_shelf, sfc_state, & +subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & time_step, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields type(surface), intent(inout) :: sfc_state !< A structure containing fields that @@ -113,8 +115,8 @@ subroutine iceberg_fluxes(G, fluxes, use_ice_shelf, sfc_state, & real, intent(in) :: time_step !< The coupling time step [s]. type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice - real :: fraz ! refreezing rate [kg m-2 s-1] - real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [kg J-1 s-1]. + real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1] + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [kg J-1 T-1 ~> kg J-1 s-1]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed @@ -142,7 +144,7 @@ subroutine iceberg_fluxes(G, fluxes, use_ice_shelf, sfc_state, & !Zero'ing out other fluxes under the tabular icebergs if (CS%berg_area_threshold >= 0.) then - I_dt_LHF = 1.0 / (time_step * CS%latent_heat_fusion) + I_dt_LHF = 1.0 / (US%s_to_T*time_step * CS%latent_heat_fusion) do j=jsd,jed ; do i=isd,ied if (fluxes%frac_shelf_h(i,j) > CS%berg_area_threshold) then ! Only applying for ice shelf covering most of cell. @@ -153,13 +155,14 @@ subroutine iceberg_fluxes(G, fluxes, use_ice_shelf, sfc_state, & if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 ! Add frazil formation diagnosed by the ocean model [J m-2] in the - ! form of surface layer evaporation [kg m-2 s-1]. Update lprec in the + ! form of surface layer evaporation [R Z T-1 ~> kg m-2 s-1]. Update lprec in the ! control structure for diagnostic purposes. if (associated(sfc_state%frazil)) then - fraz = sfc_state%frazil(i,j) * I_dt_LHF - if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz - !CS%lprec(i,j)=CS%lprec(i,j) - fraz + fraz = US%kg_m3_to_R*US%m_to_Z*sfc_state%frazil(i,j) * I_dt_LHF + if (associated(fluxes%evap)) & + fluxes%evap(i,j) = fluxes%evap(i,j) - fraz + ! fluxes%lprec(i,j) = fluxes%lprec(i,j) - fraz sfc_state%frazil(i,j) = 0.0 endif diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index aa101fb9f1..e09b21f251 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -514,10 +514,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RmixConst = 0.5*CS%rivermix_depth * (GV%g_Earth*US%m_to_Z) * Irho0**2 + RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 do i=is,ie TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & - US%T_to_s*US%kg_m3_to_R*(fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) enddo else do i=is,ie ; TKE_river(i) = 0.0 ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index e21323f6b8..ad2f57f2d4 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1130,12 +1130,12 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (GV%Boussinesq) then - RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + RivermixConst = -0.5*(CS%rivermix_depth*US%s_to_T*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 else - RivermixConst = -0.5*(CS%rivermix_depth*dt)*(US%m_to_Z) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) + RivermixConst = -0.5*(CS%rivermix_depth*US%s_to_T*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) endif cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & - US%kg_m3_to_R*(fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) endif ! Update state diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index d12897038f..28f31c6fa1 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -457,7 +457,8 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) !nnz: Why is fluxes%river = 0? - runoff_tracer_flux_array = trunoff_array * fluxes%lrunoff + runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & + G%US%R_to_kg_m3*G%US%Z_to_m*G%US%s_to_T*fluxes%lrunoff(:,:) stf_array = stf_array + runoff_tracer_flux_array endif @@ -492,9 +493,10 @@ 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%US%L_to_m**2*G%areaT, get_diag_time_end(CS%diag), & + G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & - internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) + internal_heat=tv%internal_heat, & + frunoff=G%US%R_to_kg_m3*G%US%Z_to_m*G%US%s_to_T*fluxes%frunoff(:,:), sosga=sosga) ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes ! usually in ALE mode diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 558be86734..bce0698240 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -136,9 +136,8 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - state%SSS(i,j)) / & - (0.5 * (Salin_restore + state%SSS(i,j)))) + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const)) * & + ((Salin_restore - state%SSS(i,j)) / (0.5 * (Salin_restore + state%SSS(i,j)))) enddo ; enddo else ! When modifying the code, comment out this error message. It is here diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index a61600fa56..960abd49ca 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -227,11 +227,12 @@ subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) end subroutine SCM_CVMix_tests_wind_forcing -subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, CS) +subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) type(surface), intent(in) :: state !< Surface state structure type(forcing), intent(inout) :: fluxes !< Surface fluxes structure type(time_type), intent(in) :: day !< Current model time type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(SCM_CVMix_tests_CS), pointer :: CS !< Container for SCM parameters ! Local variables @@ -259,9 +260,9 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, CS) if (CS%UseEvaporation) then do J=Jsq,Jeq ; do i=is,ie ! Note CVMix test inputs give evaporation in [m s-1] - ! This therefore must be converted to mass flux - ! by multiplying by density - fluxes%evap(i,J) = CS%surf_evap * CS%Rho0 + ! This therefore must be converted to mass flux in [R Z T-1 ~> kg m-2 s-1] + ! by multiplying by density and some unit conversion factors. + fluxes%evap(i,J) = CS%surf_evap * US%kg_m3_to_R*US%m_to_Z*US%T_to_s * CS%Rho0 enddo ; enddo endif diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index d8b3ad269b..4f9483d7e5 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -47,7 +47,7 @@ module dumbbell_surface_forcing contains !> Surface buoyancy (heat and fresh water) fluxes for the dumbbell test case -subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, CS) +subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any @@ -57,6 +57,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, CS) real, intent(in) :: dt !< The amount of time over which !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(dumbbell_surface_forcing_CS), pointer :: CS !< A control structure returned by a previous !! call to dumbbell_surface_forcing_init ! Local variables @@ -123,9 +124,8 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, CS) ! Set density_restore to an expression for the surface potential ! density [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)))) + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*US%m_to_Z*US%T_to_s*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)))) endif enddo ; enddo From a5082d55461e8dd1c159b8488777f1dd85a56027 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 4 Oct 2019 20:13:59 -0400 Subject: [PATCH 157/259] Travis python support; tc4 Makefile The custom TC4 Makefile has been added (oops), and the presumed Python Ubuntu packages have been added for Travis. --- .testing/tc4/Makefile | 3 +++ .travis.yml | 1 + 2 files changed, 4 insertions(+) create mode 100644 .testing/tc4/Makefile diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile new file mode 100644 index 0000000000..cea78bf3bd --- /dev/null +++ b/.testing/tc4/Makefile @@ -0,0 +1,3 @@ +all: + python build_grid.py + python build_data.py diff --git a/.travis.yml b/.travis.yml index 41d9d9b348..ac37117709 100644 --- a/.travis.yml +++ b/.travis.yml @@ -17,6 +17,7 @@ addons: packages: - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev openmpi-bin libopenmpi-dev gfortran - doxygen graphviz flex bison cmake + - python-numpy python-netcdf4 jobs: include: From 76172d4d5975f79bb93d33a93d1f9f974742099d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Oct 2019 07:22:09 -0400 Subject: [PATCH 158/259] Simplified scaling factors in MOM_forcing_type Simplified scaling factors in MOM_forcing_type or encapsulated groups of scaling factors in local variables. All answers are bitwise identical. --- src/core/MOM_forcing_type.F90 | 193 +++++++++++++++++----------------- 1 file changed, 97 insertions(+), 96 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a5e56b9ad1..cc94e446cd 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -411,7 +411,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, real :: Ih_limit ! inverse depth at which surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth real :: J_m2_to_H ! converts J/m^2 to H units (m for Bouss and kg/m^2 for non-Bouss) - real :: Irho0 ! 1.0 / Rho0 [m3 kg-1] + real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature + ! change [W m-2 degC-1 T R-1 Z-1 ~> J kg degC] + real :: dt_in_T ! The timestep [T ~> s] real :: I_Cp ! 1.0 / C_p [kg decC J-1] logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays character(len=200) :: mesg @@ -434,7 +436,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, !}BGR Ih_limit = 1.0 / FluxRescaleDepth - Irho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) + RZ_T_to_W_m2_degC = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T + dt_in_T = dt * US%s_to_T I_Cp = 1.0 / fluxes%C_p J_m2_to_H = 1.0 / (GV%H_to_kg_m2 * fluxes%C_p) @@ -509,7 +512,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, endif ! net volume/mass of liquid and solid passing through surface boundary fluxes - netMassInOut(i) = dt * (scale * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*& + netMassInOut(i) = dt_in_T * (scale * & (((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & @@ -519,7 +522,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, + fluxes%frunoff(i,j) )) if (do_NMIOr) then ! Repeat the above code w/ dt=1s for legacy reasons - netMassInOut_rate(i) = (scale * US%R_to_kg_m3*US%Z_to_m*US%s_to_T* & + netMassInOut_rate(i) = (scale * US%s_to_T* & (((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & @@ -535,8 +538,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! is added to the ocean, which may still need to be coded. Not that the units ! of netMassInOut are still kg_m2, so no conversion to H should occur yet. if (.not.GV%Boussinesq .and. associated(fluxes%salt_flux)) then - netMassInOut(i) = netMassInOut(i) + dt * (scale * fluxes%salt_flux(i,j)) - if (do_NMIOr) netMassInOut_rate(i) = netMassInOut_rate(i) + (scale * fluxes%salt_flux(i,j)) + netMassInOut(i) = netMassInOut(i) + dt * (scale * US%kg_m3_to_R*US%m_to_Z*fluxes%salt_flux(i,j)) + if (do_NMIOr) netMassInOut_rate(i) = netMassInOut_rate(i) + & + (scale * US%kg_m3_to_R*US%m_to_Z*fluxes%salt_flux(i,j)) endif ! net volume/mass of water leaving the ocean. @@ -546,33 +550,26 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! evap > 0 means condensating water is added into ocean. ! evap < 0 means evaporation of water from the ocean, in ! which case heat_content_evap is computed in MOM_diabatic_driver.F90 - if (fluxes%evap(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) + if (fluxes%evap(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%evap(i,j) ! if (associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA - endif ! lprec < 0 means sea ice formation taking water from the ocean. ! smg: we should split the ice melt/formation from the lprec - if (fluxes%lprec(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) - endif + if (fluxes%lprec(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%lprec(i,j) ! seaice_melt < 0 means sea ice formation taking water from the ocean. - if (fluxes%seaice_melt(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) - endif + if (fluxes%seaice_melt(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%seaice_melt(i,j) ! vprec < 0 means virtual evaporation arising from surface salinity restoring, ! in which case heat_content_vprec is computed in MOM_diabatic_driver.F90. - if (fluxes%vprec(i,j) < 0.0) then - netMassOut(i) = netMassOut(i) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) - endif - netMassOut(i) = dt * scale * netMassOut(i) + if (fluxes%vprec(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%vprec(i,j) + + netMassOut(i) = dt_in_T * scale * netMassOut(i) ! convert to H units (Bouss=meter or non-Bouss=kg/m^2) - netMassInOut(i) = GV%kg_m2_to_H * netMassInOut(i) - if (do_NMIOr) netMassInOut_rate(i) = GV%kg_m2_to_H * netMassInOut_rate(i) - netMassOut(i) = GV%kg_m2_to_H * netMassOut(i) + netMassInOut(i) = GV%RZ_to_H * netMassInOut(i) + if (do_NMIOr) netMassInOut_rate(i) = GV%RZ_to_H * netMassInOut_rate(i) + netMassOut(i) = GV%RZ_to_H * netMassOut(i) ! surface heat fluxes from radiation and turbulent fluxes (K * H) ! (H=m for Bouss, H=kg/m2 for non-Bouss) @@ -596,24 +593,24 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. if (associated(fluxes%heat_added)) then - net_heat(i) = net_heat(i) + (scale * (dt * J_m2_to_H)) * fluxes%heat_added(i,j) - if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (J_m2_to_H)) * fluxes%heat_added(i,j) + net_heat(i) = net_heat(i) + (scale * (dt * J_m2_to_H)) * fluxes%heat_added(i,j) + if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (J_m2_to_H)) * fluxes%heat_added(i,j) endif ! Add explicit heat flux for runoff (which is part of the ice-ocean boundary ! flux type). Runoff is otherwise added with a temperature of SST. if (useRiverHeatContent) then ! remove lrunoff*SST here, to counteract its addition elsewhere - net_heat(i) = (net_heat(i) + (scale*(dt*J_m2_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & - (GV%kg_m2_to_H * (scale * dt)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) * T(i,1) + net_heat(i) = (net_heat(i) + (scale*(dt_in_T*J_m2_to_H)) * US%T_to_s*fluxes%heat_content_lrunoff(i,j)) - & + (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%lrunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & - ! (GV%kg_m2_to_H * (scale)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) * T(i,1) + ! (GV%RZ_to_H * (scale)) * US%s_to_T*fluxes%lrunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then - tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & - (I_Cp*fluxes%heat_content_lrunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j)*T(i,1)) + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & + (I_Cp*US%T_to_s*fluxes%heat_content_lrunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*fluxes%lrunoff(i,j)*T(i,1)) endif endif @@ -621,16 +618,16 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! flux type). Calving is otherwise added with a temperature of SST. if (useCalvingHeatContent) then ! remove frunoff*SST here, to counteract its addition elsewhere - net_heat(i) = net_heat(i) + (scale*(dt*J_m2_to_H)) * fluxes%heat_content_frunoff(i,j) - & - (GV%kg_m2_to_H * (scale * dt)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) * T(i,1) + net_heat(i) = net_heat(i) + (scale*(dt_in_T*J_m2_to_H)) * US%T_to_s*fluxes%heat_content_frunoff(i,j) - & + (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%frunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. ! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_frunoff(i,j) - & -! (GV%kg_m2_to_H * (scale)) * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) * T(i,1) +! (GV%RZ_to_H * (scale)) * US%s_to_T*fluxes%frunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then - tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & - (I_Cp*fluxes%heat_content_frunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*T(i,1)) + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & + (I_Cp*US%T_to_s*fluxes%heat_content_frunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*fluxes%frunoff(i,j)*T(i,1)) endif endif @@ -732,7 +729,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! wait until MOM_diabatic_driver.F90. if (associated(fluxes%heat_content_lprec)) then if (fluxes%lprec(i,j) > 0.0) then - fluxes%heat_content_lprec(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j)*T(i,1) + fluxes%heat_content_lprec(i,j) = RZ_T_to_W_m2_degC*fluxes%lprec(i,j)*T(i,1) else fluxes%heat_content_lprec(i,j) = 0.0 endif @@ -743,7 +740,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! and until we do so fprec is treated like lprec and enters at SST. -AJA if (associated(fluxes%heat_content_fprec)) then if (fluxes%fprec(i,j) > 0.0) then - fluxes%heat_content_fprec(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*T(i,1) + fluxes%heat_content_fprec(i,j) = RZ_T_to_W_m2_degC*fluxes%fprec(i,j)*T(i,1) else fluxes%heat_content_fprec(i,j) = 0.0 endif @@ -752,7 +749,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Following lprec and fprec, water flux due to sea ice melt (seaice_melt) enters at SST - GMM if (associated(fluxes%heat_content_icemelt)) then if (fluxes%seaice_melt(i,j) > 0.0) then - fluxes%heat_content_icemelt(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j)*T(i,1) + fluxes%heat_content_icemelt(i,j) = RZ_T_to_W_m2_degC*fluxes%seaice_melt(i,j)*T(i,1) else fluxes%heat_content_icemelt(i,j) = 0.0 endif @@ -763,7 +760,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 if (associated(fluxes%heat_content_vprec)) then if (fluxes%vprec(i,j) > 0.0) then - fluxes%heat_content_vprec(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j)*T(i,1) + fluxes%heat_content_vprec(i,j) = RZ_T_to_W_m2_degC*fluxes%vprec(i,j)*T(i,1) else fluxes%heat_content_vprec(i,j) = 0.0 endif @@ -777,7 +774,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Condensation is assumed to drop into the ocean at the SST, just like lprec. if (associated(fluxes%heat_content_cond)) then if (fluxes%evap(i,j) > 0.0) then - fluxes%heat_content_cond(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j)*T(i,1) + fluxes%heat_content_cond(i,j) = RZ_T_to_W_m2_degC*fluxes%evap(i,j)*T(i,1) else fluxes%heat_content_cond(i,j) = 0.0 endif @@ -786,14 +783,14 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Liquid runoff enters ocean at SST if land model does not provide runoff heat content. if (.not. useRiverHeatContent) then if (associated(fluxes%lrunoff) .and. associated(fluxes%heat_content_lrunoff)) then - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j)*T(i,1) + fluxes%heat_content_lrunoff(i,j) = RZ_T_to_W_m2_degC*fluxes%lrunoff(i,j)*T(i,1) endif endif ! Icebergs enter ocean at SST if land model does not provide calving heat content. if (.not. useCalvingHeatContent) then if (associated(fluxes%frunoff) .and. associated(fluxes%heat_content_frunoff)) then - fluxes%heat_content_frunoff(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*T(i,1) + fluxes%heat_content_frunoff(i,j) = RZ_T_to_W_m2_degC*fluxes%frunoff(i,j)*T(i,1) endif endif @@ -902,8 +899,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band ! [degC H ~> degC m or degC kg m-2] real, dimension(SZI_(G)) :: pressure ! pressurea the surface [Pa] - real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [kg m-3 degC-1] - real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [kg m-3 ppt-1] + real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R degC-1 ~> kg m-3 degC-1] + real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R ppt-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G),SZK_(G)+1) :: netPen ! The net penetrating shortwave radiation at each level ! [degC H ~> degC m or degC kg m-2] @@ -911,7 +908,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt logical :: useCalvingHeatContent real :: depthBeforeScalingFluxes ! A depth scale [H ~> m or kg m-2] real :: GoRho ! The gravitational acceleration divided by mean density times some - ! unit conversion factors [L2 m3 H-1 s kg-1 T-3 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + ! unit conversion factors [L2 H-1 s R-1 T-3 ~> m4 kg-1 s-2 or m7 kg-2 s-2] real :: H_limit_fluxes ! Another depth scale [H ~> m or kg m-2] ! smg: what do we do when have heat fluxes from calving and river? @@ -920,7 +917,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt depthBeforeScalingFluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) pressure(:) = 0. ! Ignore atmospheric pressure - GoRho = (GV%g_Earth*US%m_to_Z * GV%H_to_m*US%T_to_s) / (US%R_to_kg_m3*GV%Rho0) + GoRho = (GV%g_Earth * GV%H_to_Z*US%T_to_s) / GV%Rho0 start = 1 + G%isc - G%isd npts = 1 + G%iec - G%isc @@ -945,7 +942,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! Density derivatives call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, & - dRhodT, dRhodS, start, npts, tv%eqn_of_state) + dRhodT, dRhodS, start, npts, tv%eqn_of_state, scale=US%kg_m3_to_R) ! 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) ! ppt H/s @@ -1012,10 +1009,12 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< shift in halo + real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] integer :: is, ie, js, je, nz, hshift is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - hshift=1; if (present(haloshift)) hshift=haloshift + hshift = 1 ; if (present(haloshift)) hshift = haloshift + RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie @@ -1047,16 +1046,15 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%sens)) & call hchksum(fluxes%sens, mesg//" fluxes%sens",G%HI,haloshift=hshift) if (associated(fluxes%evap)) & - call hchksum(fluxes%evap, mesg//" fluxes%evap",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + call hchksum(fluxes%evap, mesg//" fluxes%evap",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%lprec)) & - call hchksum(fluxes%lprec, mesg//" fluxes%lprec",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + call hchksum(fluxes%lprec, mesg//" fluxes%lprec",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%fprec)) & - call hchksum(fluxes%fprec, mesg//" fluxes%fprec",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + call hchksum(fluxes%fprec, mesg//" fluxes%fprec",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%vprec)) & - call hchksum(fluxes%vprec, mesg//" fluxes%vprec",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + call hchksum(fluxes%vprec, mesg//" fluxes%vprec",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%seaice_melt)) & - call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt",G%HI,haloshift=hshift, & - scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%seaice_melt_heat)) & call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat",G%HI,haloshift=hshift) if (associated(fluxes%p_surf)) & @@ -1064,14 +1062,13 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%salt_flux)) & call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux",G%HI,haloshift=hshift) if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal",G%HI,haloshift=hshift, & - scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%ustar_tidal)) & call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & - call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%frunoff)) & - call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff",G%HI,haloshift=hshift, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_lrunoff)) & call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff",G%HI,haloshift=hshift) if (associated(fluxes%heat_content_frunoff)) & @@ -2120,30 +2117,33 @@ subroutine get_net_mass_forcing(fluxes, G, US, net_mass_src) real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_mass_src !< The net mass flux of water into the ocean !! [kg m-2 s-1]. + real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T + net_mass_src(:,:) = 0.0 if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + RZ_T_conversion*fluxes%lprec(i,j) enddo ; enddo ; endif if (associated(fluxes%fprec)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + RZ_T_conversion*fluxes%fprec(i,j) enddo ; enddo ; endif if (associated(fluxes%vprec)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + RZ_T_conversion*fluxes%vprec(i,j) enddo ; enddo ; endif if (associated(fluxes%lrunoff)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + RZ_T_conversion*fluxes%lrunoff(i,j) enddo ; enddo ; endif if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + RZ_T_conversion*fluxes%frunoff(i,j) enddo ; enddo ; endif if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + RZ_T_conversion*fluxes%evap(i,j) enddo ; enddo ; endif if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie - net_mass_src(i,j) = net_mass_src(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) + net_mass_src(i,j) = net_mass_src(i,j) + RZ_T_conversion*fluxes%seaice_melt(i,j) enddo ; enddo ; endif end subroutine get_net_mass_forcing @@ -2218,6 +2218,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) real :: total_transport ! for diagnosing integrated boundary transport real :: ave_flux ! for diagnosing averaged boundary flux real :: C_p ! seawater heat capacity (J/(deg K * kg)) + real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] real :: I_dt ! inverse time step real :: ppt2mks ! conversion between ppt and mks integer :: i,j,is,ie,js,je @@ -2225,6 +2226,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) call cpu_clock_begin(handles%id_clock_forcing) C_p = fluxes%C_p + RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T I_dt = 1.0/dt ppt2mks = 1e-3 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2236,19 +2238,18 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if (handles%id_prcme > 0 .or. handles%id_total_prcme > 0 .or. handles%id_prcme_ga > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (associated(fluxes%lprec)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) - if (associated(fluxes%fprec)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j) + if (associated(fluxes%lprec)) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%lprec(i,j) + if (associated(fluxes%fprec)) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%fprec(i,j) ! fluxes%cond is not needed because it is derived from %evap > 0 - if (associated(fluxes%evap)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) - if (associated(fluxes%lrunoff)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) - if (associated(fluxes%frunoff)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) - if (associated(fluxes%vprec)) res(i,j) = res(i,j)+US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) - if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j) + & - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) + if (associated(fluxes%evap)) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%evap(i,j) + if (associated(fluxes%lrunoff)) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%lrunoff(i,j) + if (associated(fluxes%frunoff)) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%frunoff(i,j) + if (associated(fluxes%vprec)) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%vprec(i,j) + if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%seaice_melt(i,j) enddo ; enddo if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) if (handles%id_total_prcme > 0) then - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G) call post_data(handles%id_total_prcme, total_transport, diag) endif if (handles%id_prcme_ga > 0) then @@ -2261,17 +2262,17 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) do j=js,je ; do i=is,ie res(i,j) = 0.0 if (associated(fluxes%lprec)) then - if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) + if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%lprec(i,j) endif if (associated(fluxes%vprec)) then - if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) + if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%vprec(i,j) endif if (associated(fluxes%evap)) then - if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) + if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%evap(i,j) endif if (associated(fluxes%seaice_melt)) then if (fluxes%seaice_melt(i,j) < 0.0) & - res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%seaice_melt(i,j) endif enddo ; enddo if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) @@ -2289,25 +2290,25 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) res(i,j) = 0.0 if (associated(fluxes%fprec)) & - res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j) + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%fprec(i,j) if (associated(fluxes%lrunoff)) & - res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lrunoff(i,j) + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%lrunoff(i,j) if (associated(fluxes%frunoff)) & - res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j) + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%frunoff(i,j) if (associated(fluxes%lprec)) then - if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%lprec(i,j) + if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%lprec(i,j) endif if (associated(fluxes%vprec)) then - if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(i,j) + if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%vprec(i,j) endif ! fluxes%cond is not needed because it is derived from %evap > 0 if (associated(fluxes%evap)) then - if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%evap(i,j) + if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + RZ_T_conversion*fluxes%evap(i,j) endif if (associated(fluxes%seaice_melt)) then if (fluxes%seaice_melt(i,j) > 0.0) & - res(i,j) = res(i,j) + US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%seaice_melt(i,j) + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%seaice_melt(i,j) endif enddo ; enddo if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) @@ -2323,17 +2324,17 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) if ((handles%id_total_evap > 0) .and. associated(fluxes%evap)) then - total_transport = global_area_integral(fluxes%evap, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + total_transport = global_area_integral(fluxes%evap, G, scale=RZ_T_conversion) call post_data(handles%id_total_evap, total_transport, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then - ave_flux = global_area_mean(fluxes%evap, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + ave_flux = global_area_mean(fluxes%evap, G, scale=RZ_T_conversion) call post_data(handles%id_evap_ga, ave_flux, diag) endif if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie - res(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T* (fluxes%lprec(i,j) + fluxes%fprec(i,j)) + res(i,j) = RZ_T_conversion* (fluxes%lprec(i,j) + fluxes%fprec(i,j)) enddo ; enddo if (handles%id_precip > 0) call post_data(handles%id_precip, res, diag) if (handles%id_total_precip > 0) then @@ -2349,11 +2350,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if (associated(fluxes%lprec)) then if (handles%id_lprec > 0) call post_data(handles%id_lprec, fluxes%lprec, diag) if (handles%id_total_lprec > 0) then - total_transport = global_area_integral(fluxes%lprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + total_transport = global_area_integral(fluxes%lprec, G, scale=RZ_T_conversion) call post_data(handles%id_total_lprec, total_transport, diag) endif if (handles%id_lprec_ga > 0) then - ave_flux = global_area_mean(fluxes%lprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + ave_flux = global_area_mean(fluxes%lprec, G, scale=RZ_T_conversion) call post_data(handles%id_lprec_ga, ave_flux, diag) endif endif @@ -2361,11 +2362,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if (associated(fluxes%fprec)) then if (handles%id_fprec > 0) call post_data(handles%id_fprec, fluxes%fprec, diag) if (handles%id_total_fprec > 0) then - total_transport = global_area_integral(fluxes%fprec ,G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + total_transport = global_area_integral(fluxes%fprec ,G, scale=RZ_T_conversion) call post_data(handles%id_total_fprec, total_transport, diag) endif if (handles%id_fprec_ga > 0) then - ave_flux = global_area_mean(fluxes%fprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + ave_flux = global_area_mean(fluxes%fprec, G, scale=RZ_T_conversion) call post_data(handles%id_fprec_ga, ave_flux, diag) endif endif @@ -2373,11 +2374,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if (associated(fluxes%vprec)) then if (handles%id_vprec > 0) call post_data(handles%id_vprec, fluxes%vprec, diag) if (handles%id_total_vprec > 0) then - total_transport = global_area_integral(fluxes%vprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + total_transport = global_area_integral(fluxes%vprec, G, scale=RZ_T_conversion) call post_data(handles%id_total_vprec, total_transport, diag) endif if (handles%id_vprec_ga > 0) then - ave_flux = global_area_mean(fluxes%vprec, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + ave_flux = global_area_mean(fluxes%vprec, G, scale=RZ_T_conversion) call post_data(handles%id_vprec_ga, ave_flux, diag) endif endif @@ -2385,7 +2386,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if (associated(fluxes%lrunoff)) then if (handles%id_lrunoff > 0) call post_data(handles%id_lrunoff, fluxes%lrunoff, diag) if (handles%id_total_lrunoff > 0) then - total_transport = global_area_integral(fluxes%lrunoff, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + total_transport = global_area_integral(fluxes%lrunoff, G, scale=RZ_T_conversion) call post_data(handles%id_total_lrunoff, total_transport, diag) endif endif @@ -2393,7 +2394,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if (associated(fluxes%frunoff)) then if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) if (handles%id_total_frunoff > 0) then - total_transport = global_area_integral(fluxes%frunoff, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + total_transport = global_area_integral(fluxes%frunoff, G, scale=RZ_T_conversion) call post_data(handles%id_total_frunoff, total_transport, diag) endif endif @@ -2401,7 +2402,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if (associated(fluxes%seaice_melt)) then if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) if (handles%id_total_seaice_melt > 0) then - total_transport = global_area_integral(fluxes%seaice_melt, G, scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + total_transport = global_area_integral(fluxes%seaice_melt, G, scale=RZ_T_conversion) call post_data(handles%id_total_seaice_melt, total_transport, diag) endif endif From 965c2c290a09191258882fe9d4478892ce554c91 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Oct 2019 09:38:05 -0400 Subject: [PATCH 159/259] +Rescaled _rate variables from extractFluxes1d Rescaled the units of optional _rate variables returned by extractFluxes1d and simplified the calculations using these variables in applyBoundaryFluxesInOut. All answers are bitwise identical, but the units of arguments to a public type have changed. --- src/core/MOM_forcing_type.F90 | 35 ++++++++++--------- .../vertical/MOM_diabatic_aux.F90 | 34 ++++++++++-------- 2 files changed, 39 insertions(+), 30 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index cc94e446cd..f559631606 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -339,7 +339,7 @@ module MOM_forcing_type subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent, & h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & - aggregate_FW, nonpenSW, netmassInOut_rate,net_Heat_Rate, & + aggregate_FW, nonpenSW, netmassInOut_rate, net_Heat_Rate, & net_salt_rate, pen_sw_bnd_Rate, skip_diags) type(ocean_grid_type), intent(in) :: G !< ocean grid structure @@ -392,22 +392,23 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, !! Summed over SW bands when diagnosing nonpenSW. real, dimension(SZI_(G)), & optional, intent(out) :: net_Heat_rate !< Rate of net surface heating - !! [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1]. + !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1]. real, dimension(SZI_(G)), & optional, intent(out) :: net_salt_rate !< Surface salt flux into the ocean - !! [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1]. + !! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. real, dimension(SZI_(G)), & optional, intent(out) :: netmassInOut_rate !< Rate of net mass flux into the ocean - !! [H s-1 ~> m s-1 or kg m-2 s-1]. + !! [H T-1 ~> m s-1 or kg m-2 s-1]. real, dimension(max(1,nsw),G%isd:G%ied), & optional, intent(out) :: pen_sw_bnd_rate !< Rate of penetrative shortwave heating - !! [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1]. + !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1]. logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating diagnostics ! local real :: htot(SZI_(G)) ! total ocean depth [H ~> m or kg m-2] real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW [degC H ~> degC m or degC kg m-2]. - real :: pen_sw_tot_rate(SZI_(G)) ! Similar but sum but as a rate (no dt in calculation) + real :: pen_sw_tot_rate(SZI_(G)) ! Summed rate of shortwave heating across bands + ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] real :: Ih_limit ! inverse depth at which surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth real :: J_m2_to_H ! converts J/m^2 to H units (m for Bouss and kg/m^2 for non-Bouss) @@ -503,7 +504,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, pen_sw_tot_rate(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd_rate(n,i) = J_m2_to_H*scale * max(0.0, Pen_SW_bnd_rate(n,i)) + Pen_SW_bnd_rate(n,i) = J_m2_to_H*US%T_to_s*scale * max(0.0, Pen_SW_bnd_rate(n,i)) pen_sw_tot_rate(i) = pen_sw_tot_rate(i) + pen_sw_bnd_rate(n,i) enddo else @@ -521,8 +522,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, + fluxes%seaice_melt(i,j)) & + fluxes%frunoff(i,j) )) - if (do_NMIOr) then ! Repeat the above code w/ dt=1s for legacy reasons - netMassInOut_rate(i) = (scale * US%s_to_T* & + if (do_NMIOr) then ! Repeat the above code without multiplying by a timestep for legacy reasons + netMassInOut_rate(i) = (scale * & (((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & @@ -540,7 +541,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, if (.not.GV%Boussinesq .and. associated(fluxes%salt_flux)) then netMassInOut(i) = netMassInOut(i) + dt * (scale * US%kg_m3_to_R*US%m_to_Z*fluxes%salt_flux(i,j)) if (do_NMIOr) netMassInOut_rate(i) = netMassInOut_rate(i) + & - (scale * US%kg_m3_to_R*US%m_to_Z*fluxes%salt_flux(i,j)) + (scale * US%kg_m3_to_R*US%m_to_Z*US%T_to_s*fluxes%salt_flux(i,j)) endif ! net volume/mass of water leaving the ocean. @@ -580,21 +581,21 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * J_m2_to_H * & + if (do_NHR) net_heat_rate(i) = scale * US%T_to_s*J_m2_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & fluxes%seaice_melt_heat(i,j))) else net_heat(i) = scale * dt * J_m2_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * J_m2_to_H * & + if (do_NHR) net_heat_rate(i) = scale * US%T_to_s*J_m2_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) endif ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. if (associated(fluxes%heat_added)) then net_heat(i) = net_heat(i) + (scale * (dt * J_m2_to_H)) * fluxes%heat_added(i,j) - if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (J_m2_to_H)) * fluxes%heat_added(i,j) + if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (US%T_to_s*J_m2_to_H)) * fluxes%heat_added(i,j) endif ! Add explicit heat flux for runoff (which is part of the ice-ocean boundary @@ -605,7 +606,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%lrunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. - !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & + !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(US%T_to_s*J_m2_to_H)) * & + ! fluxes%heat_content_lrunoff(i,j)) - & ! (GV%RZ_to_H * (scale)) * US%s_to_T*fluxes%lrunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then @@ -622,7 +624,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%frunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. -! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_frunoff(i,j) - & +! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*(US%T_to_s*J_m2_to_H)) * & +! fluxes%heat_content_frunoff(i,j) - & ! (GV%RZ_to_H * (scale)) * US%s_to_T*fluxes%frunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then @@ -679,7 +682,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, if (associated(fluxes%salt_flux)) then Net_salt(i) = (scale * dt * (1000.0 * fluxes%salt_flux(i,j))) * GV%kg_m2_to_H !Repeat above code for 'rate' term - if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0 * fluxes%salt_flux(i,j))) * GV%kg_m2_to_H + if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0 * US%T_to_s*fluxes%salt_flux(i,j))) * GV%kg_m2_to_H endif ! Diagnostics follow... diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index ad2f57f2d4..e614524baa 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -901,22 +901,24 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t SurfPressure, & ! Surface pressure (approximated as 0.0) [Pa] dRhodT, & ! change in density per change in temperature [R degC-1 ~> kg m-3 degC-1] dRhodS, & ! change in density per change in salinity [R ppt-1 ~> kg m-3 ppt-1] - netheat_rate, & ! netheat but for dt=1 [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + netheat_rate, & ! netheat but for dt=1 [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) - ! [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] - netMassInOut_rate! netmassinout but for dt=1 [H s-1 ~> m s-1 or kg m-2 s-1] + ! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + netMassInOut_rate! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G), SZK_(G)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] T2d, & ! A 2-d copy of the layer temperatures [degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within ! a layer [R Z3 T-2 ~> J m-2] dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 degC-1] - real, dimension(SZI_(G),SZK_(G)+1) :: netPen + real, dimension(SZI_(G)) :: & + netPen_rate ! The surface penetrative shortwave heating rate summed over all bands + ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(max(nsw,1),SZI_(G)) :: & Pen_SW_bnd, & ! The penetrative shortwave heating integrated over a timestep by band ! [degC H ~> degC m or degC kg m-2] Pen_SW_bnd_rate ! The penetrative shortwave heating rate by band - ! [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(max(nsw,1),SZI_(G),SZK_(G)) :: & opacityBand ! The opacity (inverse of the exponential absorption length) of each frequency ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] @@ -929,7 +931,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! [Z T-2 R-1 ~> m4 s-2 kg-1] logical :: calculate_energetics logical :: calculate_buoyancy - integer :: i, j, is, ie, js, je, k, nz, n + integer :: i, j, is, ie, js, je, k, nz, n, nb integer :: start, npts character(len=45) :: mesg @@ -970,7 +972,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & !$OMP minimum_forcing_depth,evap_CFL_limit,dt_in_T, & - !$OMP calculate_buoyancy,netPen,SkinBuoyFlux,GoRho, & + !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & @@ -1334,11 +1336,15 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t 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, US, h2d(:,:), optics_nbands(optics), optics, j, dt_in_T, & - H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) + netPen_rate(:) = 0.0 + ! Sum over bands and attenuate as a function of depth. + ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, + ! in which case the values of dt, h, optics and H_limit_fluxes are irrelevant. Consider + ! writing a shorter and simpler variant to handle this very limited case. + ! call sumSWoverBands(G, GV, US, h2d(:,:), optics_nbands(optics), optics, j, dt_in_T, & + ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) + do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo + ! Density derivatives call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, & dRhodT, dRhodS, start, npts, tv%eqn_of_state, scale=US%kg_m3_to_R) @@ -1348,9 +1354,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! 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_Z * US%T_to_s * & + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & (dRhodS(i) * (netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & - dRhodT(i) * ( netHeat_rate(i) + netPen(i,1)) ) ! [Z2 T-3 ~> m2 s-3] + dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] enddo endif From 37d5405cd34c80fce91ae214dce1d45184ef75f1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Oct 2019 09:55:45 -0400 Subject: [PATCH 160/259] Combined scaling factors in MOM_forcing_type Combined scaling factors in MOM_forcing_type including the introduction of some new local variables and the use of dt_in_T in place of dt. All answers are bitwise identical. --- src/core/MOM_forcing_type.F90 | 46 +++++++++++++++++------------------ 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index f559631606..f22c1f749a 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -411,7 +411,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] real :: Ih_limit ! inverse depth at which surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth - real :: J_m2_to_H ! converts J/m^2 to H units (m for Bouss and kg/m^2 for non-Bouss) + real :: W_m2_to_H_T ! converts W/m^2 to H degC T-1 [degC H T-1 W-2 m2 ~> degC m3 J-1 or degC kg J-1] real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature ! change [W m-2 degC-1 T R-1 Z-1 ~> J kg degC] real :: dt_in_T ! The timestep [T ~> s] @@ -440,7 +440,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, RZ_T_to_W_m2_degC = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T dt_in_T = dt * US%s_to_T I_Cp = 1.0 / fluxes%C_p - J_m2_to_H = 1.0 / (GV%H_to_kg_m2 * fluxes%C_p) + W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * fluxes%C_p) is = G%isc ; ie = G%iec ; nz = G%ke @@ -479,8 +479,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,k) ; enddo ; enddo if (nsw >= 1) then - call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd) !, penSW_scale=J_m2_to_H*dt - if (do_PSWBR) call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd_rate) !, penSW_scale=J_m2_to_H + call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd) !, penSW_scale=W_m2_to_H_T*dt_in_T + if (do_PSWBR) call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd_rate) !, penSW_scale=W_m2_to_H_T endif do i=is,ie @@ -493,7 +493,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, Pen_sw_tot(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd(n,i) = J_m2_to_H*scale*dt * max(0.0, Pen_SW_bnd(n,i)) + Pen_SW_bnd(n,i) = W_m2_to_H_T*scale*dt_in_T * max(0.0, Pen_SW_bnd(n,i)) Pen_sw_tot(i) = Pen_sw_tot(i) + Pen_SW_bnd(n,i) enddo else @@ -504,7 +504,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, pen_sw_tot_rate(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd_rate(n,i) = J_m2_to_H*US%T_to_s*scale * max(0.0, Pen_SW_bnd_rate(n,i)) + Pen_SW_bnd_rate(n,i) = W_m2_to_H_T*scale * max(0.0, Pen_SW_bnd_rate(n,i)) pen_sw_tot_rate(i) = pen_sw_tot_rate(i) + pen_sw_bnd_rate(n,i) enddo else @@ -577,38 +577,37 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below if (associated(fluxes%seaice_melt_heat)) then - net_heat(i) = scale * dt * J_m2_to_H * & + net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * US%T_to_s*J_m2_to_H * & + if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & fluxes%seaice_melt_heat(i,j))) else - net_heat(i) = scale * dt * J_m2_to_H * & + net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * US%T_to_s*J_m2_to_H * & + if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) endif ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. if (associated(fluxes%heat_added)) then - net_heat(i) = net_heat(i) + (scale * (dt * J_m2_to_H)) * fluxes%heat_added(i,j) - if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (US%T_to_s*J_m2_to_H)) * fluxes%heat_added(i,j) + net_heat(i) = net_heat(i) + (scale * (dt_in_T * W_m2_to_H_T)) * fluxes%heat_added(i,j) + if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (W_m2_to_H_T)) * fluxes%heat_added(i,j) endif ! Add explicit heat flux for runoff (which is part of the ice-ocean boundary ! flux type). Runoff is otherwise added with a temperature of SST. if (useRiverHeatContent) then ! remove lrunoff*SST here, to counteract its addition elsewhere - net_heat(i) = (net_heat(i) + (scale*(dt_in_T*J_m2_to_H)) * US%T_to_s*fluxes%heat_content_lrunoff(i,j)) - & + net_heat(i) = (net_heat(i) + (scale*(dt_in_T * W_m2_to_H_T)) * fluxes%heat_content_lrunoff(i,j)) - & (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%lrunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. - !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(US%T_to_s*J_m2_to_H)) * & - ! fluxes%heat_content_lrunoff(i,j)) - & - ! (GV%RZ_to_H * (scale)) * US%s_to_T*fluxes%lrunoff(i,j) * T(i,1) + !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(W_m2_to_H_T)) * fluxes%heat_content_lrunoff(i,j)) - & + ! (GV%RZ_to_H * (scale)) * fluxes%lrunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & @@ -620,13 +619,12 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! flux type). Calving is otherwise added with a temperature of SST. if (useCalvingHeatContent) then ! remove frunoff*SST here, to counteract its addition elsewhere - net_heat(i) = net_heat(i) + (scale*(dt_in_T*J_m2_to_H)) * US%T_to_s*fluxes%heat_content_frunoff(i,j) - & + net_heat(i) = net_heat(i) + (scale*(dt_in_T * W_m2_to_H_T)) * fluxes%heat_content_frunoff(i,j) - & (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%frunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. -! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*(US%T_to_s*J_m2_to_H)) * & -! fluxes%heat_content_frunoff(i,j) - & -! (GV%RZ_to_H * (scale)) * US%s_to_T*fluxes%frunoff(i,j) * T(i,1) +! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*W_m2_to_H_T) * fluxes%heat_content_frunoff(i,j) - & +! (GV%RZ_to_H * scale) * fluxes%frunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & @@ -644,19 +642,19 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! When evap, lprec, or vprec > 0, then we know their heat content here ! via settings from inside of the appropriate config_src driver files. ! if (associated(fluxes%heat_content_lprec)) then -! net_heat(i) = net_heat(i) + scale * dt * J_m2_to_H * & +! net_heat(i) = net_heat(i) + scale * dt_in_T * W_m2_to_H_T * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) + & ! (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) + & ! (fluxes%heat_content_cond(i,j) + fluxes%heat_content_vprec(i,j)))))) ! endif if (fluxes%num_msg < fluxes%max_msg) then - if (Pen_SW_tot(i) > 1.000001*J_m2_to_H*scale*dt*fluxes%sw(i,j)) then + if (Pen_SW_tot(i) > 1.000001 * W_m2_to_H_T*scale*dt_in_T*fluxes%sw(i,j)) then fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& &" at ",1pg11.4,"E, "1pg11.4,"N.")') & - Pen_SW_tot(i),J_m2_to_H*scale*dt*fluxes%sw(i,j),& + Pen_SW_tot(i),W_m2_to_H_T*scale*dt_in_T * fluxes%sw(i,j),& G%geoLonT(i,j),G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif @@ -670,7 +668,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! diagnose non-downwelling SW if (present(nonPenSW)) then - nonPenSW(i) = scale * dt * J_m2_to_H * fluxes%sw(i,j) - Pen_SW_tot(i) + nonPenSW(i) = scale * dt_in_T * W_m2_to_H_T * fluxes%sw(i,j) - Pen_SW_tot(i) endif ! Salt fluxes From be8e18c3a8057f6c6c059723234dfdd855c60e22 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Oct 2019 11:32:34 -0400 Subject: [PATCH 161/259] +Rescaled the units of surface salt fluxes Rescaled the units of 3 surface salt flux elements to [R Z T-1] in the forcing type, including salt_flux, salt_flux_in, and salt_flux_added. Also added a unit_scaling_type arguments to insert_brine. All answers are bitwise identical, but the units of 3 elements of a widely used public type have changed and there is a new subroutine argument. --- .../MOM_surface_forcing_gfdl.F90 | 20 +++++----- .../mct_driver/mom_surface_forcing_mct.F90 | 19 +++++---- .../mom_surface_forcing_nuopc.F90 | 19 +++++---- src/core/MOM_forcing_type.F90 | 39 ++++++++++--------- src/diagnostics/MOM_sum_output.F90 | 3 +- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- .../vertical/MOM_diabatic_aux.F90 | 5 ++- .../vertical/MOM_diabatic_driver.F90 | 4 +- 8 files changed, 62 insertions(+), 49 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 766f2127c6..40d336ec69 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -355,17 +355,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (US%R_to_kg_m3*CS%Rho0*CS%Flux_const)* & - (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*US%m_to_Z*US%T_to_s*CS%Flux_const)* & + (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) + call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & + unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic @@ -548,8 +550,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc ! more salt restoring logic if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) - IOB%salt_flux(i-i0,j-j0)) - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( -IOB%salt_flux(i-i0,j-j0) ) + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) - kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( -kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0) ) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%salt_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'salt_flux', G) enddo ; enddo @@ -906,7 +908,6 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, IRho0 = US%L_to_Z / CS%Rho0 Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z stress_conversion = Pa_conversion * CS%wind_stress_multiplier - !### Pa_conversion*US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L = 1.0 do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) @@ -1119,7 +1120,8 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + & + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index f9489c8a42..fa1dfbce5c 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -358,17 +358,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (US%R_to_kg_m3*CS%Rho0*CS%Flux_const)* & - (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*US%m_to_Z*US%T_to_s*CS%Flux_const)* & + (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) + call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & + unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic @@ -528,8 +530,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + IOB%salt_flux(i-i0,j-j0)) - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( IOB%salt_flux(i-i0,j-j0) ) + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0) ) enddo ; enddo endif @@ -898,7 +900,8 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + & + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index f81ea561db..e710b0be19 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -364,17 +364,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (US%R_to_kg_m3*CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*US%m_to_Z*US%T_to_s*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) + call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & + unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + work_sum(is:ie,js:je) = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic @@ -384,7 +386,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (US%R_to_kg_m3*CS%Rho0*CS%Flux_const) * & + (US%m_to_Z*US%T_to_s * CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -522,8 +524,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + IOB%salt_flux(i-i0,j-j0)) - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( IOB%salt_flux(i-i0,j-j0) ) + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0) ) enddo ; enddo endif @@ -895,7 +897,8 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + & + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index f22c1f749a..db15bf1cfa 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -107,10 +107,10 @@ module MOM_forcing_type ! salt mass flux (contributes to ocean mass only if non-Bouss ) real, pointer, dimension(:,:) :: & - salt_flux => NULL(), & !< net salt flux into the ocean [kgSalt m-2 s-1] - salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler [kgSalt m-2 s-1] + salt_flux => NULL(), & !< net salt flux into the ocean [R Z T-1 ~> kgSalt m-2 s-1] + salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler [R Z T-1 ~> kgSalt m-2 s-1] salt_flux_added => NULL() !< additional salt flux from restoring or flux adjustment before adjustment - !! to net zero [kgSalt m-2 s-1] + !! to net zero [R Z T-1 ~> kgSalt m-2 s-1] ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() @@ -539,9 +539,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! is added to the ocean, which may still need to be coded. Not that the units ! of netMassInOut are still kg_m2, so no conversion to H should occur yet. if (.not.GV%Boussinesq .and. associated(fluxes%salt_flux)) then - netMassInOut(i) = netMassInOut(i) + dt * (scale * US%kg_m3_to_R*US%m_to_Z*fluxes%salt_flux(i,j)) + netMassInOut(i) = netMassInOut(i) + dt_in_T * (scale * fluxes%salt_flux(i,j)) if (do_NMIOr) netMassInOut_rate(i) = netMassInOut_rate(i) + & - (scale * US%kg_m3_to_R*US%m_to_Z*US%T_to_s*fluxes%salt_flux(i,j)) + (scale * fluxes%salt_flux(i,j)) endif ! net volume/mass of water leaving the ocean. @@ -678,9 +678,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Boussinesq: (ppt * m) ! non-Bouss: (g/m^2) if (associated(fluxes%salt_flux)) then - Net_salt(i) = (scale * dt * (1000.0 * fluxes%salt_flux(i,j))) * GV%kg_m2_to_H + Net_salt(i) = (scale * dt_in_T * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H !Repeat above code for 'rate' term - if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0 * US%T_to_s*fluxes%salt_flux(i,j))) * GV%kg_m2_to_H + if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H endif ! Diagnostics follow... @@ -688,7 +688,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, ! Store Net_salt for unknown reason? if (associated(fluxes%salt_flux)) then - if (calculate_diags) fluxes%netSalt(i,j) = Net_salt(i) + ! This seems like a bad idea to me. -RWH + if (calculate_diags) fluxes%netSalt(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*Net_salt(i) endif ! Initialize heat_content_massin that is diagnosed in mixedlayer_convection or @@ -1061,9 +1062,10 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%p_surf)) & call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf",G%HI,haloshift=hshift) if (associated(fluxes%salt_flux)) & - call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux",G%HI,haloshift=hshift) + call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal",G%HI,haloshift=hshift, & + scale=US%R_to_kg_m3**3*US%Z_to_m**3*US%s_to_T) if (associated(fluxes%ustar_tidal)) & call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & @@ -1786,21 +1788,22 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_saltflux = register_diag_field('ocean_model', 'salt_flux', diag%axesT1, Time,& 'Net salt flux into ocean at surface (restoring + sea-ice)', & - 'kg m-2 s-1',cmor_field_name='sfdsi', & - cmor_standard_name='downward_sea_ice_basal_salt_flux', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + cmor_field_name='sfdsi', cmor_standard_name='downward_sea_ice_basal_salt_flux', & cmor_long_name='Downward Sea Ice Basal Salt Flux') handles%id_saltFluxIn = register_diag_field('ocean_model', 'salt_flux_in', diag%axesT1, Time, & - 'Salt flux into ocean at surface from coupler', 'kg m-2 s-1') + 'Salt flux into ocean at surface from coupler', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_saltFluxAdded = register_diag_field('ocean_model', 'salt_flux_added', & diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & - 'kg m-2 s-1') + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_saltFluxGlobalAdj = register_scalar_field('ocean_model', & 'salt_flux_global_restoring_adjustment', Time, diag, & 'Adjustment needed to balance net global salt flux into ocean at surface', & - 'kg m-2 s-1') + units='kg m-2 s-1') !, conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_vPrecGlobalAdj = register_scalar_field('ocean_model', & 'vprec_global_adjustment', Time, diag, & @@ -2705,21 +2708,21 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if ((handles%id_saltflux > 0) .and. associated(fluxes%salt_flux)) & call post_data(handles%id_saltflux, fluxes%salt_flux, diag) if ((handles%id_total_saltflux > 0) .and. associated(fluxes%salt_flux)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux,G) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, scale=RZ_T_conversion) call post_data(handles%id_total_saltflux, total_transport, diag) endif if ((handles%id_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) & call post_data(handles%id_saltFluxAdded, fluxes%salt_flux_added, diag) if ((handles%id_total_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added,G) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, scale=RZ_T_conversion) call post_data(handles%id_total_saltFluxAdded, total_transport, diag) endif if (handles%id_saltFluxIn > 0 .and. associated(fluxes%salt_flux_in)) & call post_data(handles%id_saltFluxIn, fluxes%salt_flux_in, diag) if ((handles%id_total_saltFluxIn > 0) .and. associated(fluxes%salt_flux_in)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in,G) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, scale=RZ_T_conversion) call post_data(handles%id_total_saltFluxIn, total_transport, diag) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 7bb8ba73e9..ceb004a36e 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1046,7 +1046,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (associated(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie ! convert salt_flux from kg (salt)/(m^2 s) to ppt * [m s-1]. - salt_in(i,j) = dt*G%US%L_to_m**2*G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) + salt_in(i,j) = G%US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*dt * & + G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) enddo ; enddo ; endif endif diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 76f595ee06..d82910df81 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1060,9 +1060,9 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 - fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) ! Rescale fluxes%vprec to the proper units. fluxes%vprec(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s * fluxes%vprec(i,j) + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) endif enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index e614524baa..9ef154ba8d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -382,13 +382,14 @@ end subroutine adjust_salt !> Insert salt from brine rejection into the first layer below the mixed layer !! which both contains mass and in which the change in layer density remains !! stable after the addition of salt via brine rejection. -subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) +subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) 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(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any !! available thermodynamic fields + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes integer, intent(in) :: nkmb !< The number of layers in the mixed and buffer layers type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous @@ -428,7 +429,7 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) salt(:)=0.0 ; dzbr(:)=0.0 do i=is,ie ; if (G%mask2dT(i,j) > 0.) then - salt(i) = dt * (1000. * fluxes%salt_flux(i,j)) + salt(i) = US%s_to_T*dt * (1000. * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%salt_flux(i,j)) endif ; enddo do k=1,nz diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 48318ff398..a529f60abc 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2085,7 +2085,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eaml,ebml, G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & Hml, CS%aggregate_FW_forcing, dt_in_T, last_call=.false.) if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, & + call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, & dt*CS%ML_mix_first, CS%id_brine_lay) else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) @@ -2479,7 +2479,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Hml, CS%aggregate_FW_forcing, dt_in_T, last_call=.true.) if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, US%T_to_s*dt_mix, & + call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, US%T_to_s*dt_mix, & CS%id_brine_lay) ! Keep salinity from falling below a small but positive threshold. From cbe39969be40e2483aa3a0e8ff4ecc08e5ac19f6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Oct 2019 13:32:37 -0400 Subject: [PATCH 162/259] Refactored solo_driver/MOM_surface_forcing.F90 Simplified scaling factors in the solo_driver version of MOM_surface_forcing, including rescaling of FLUX_CONST and encapsulating groups of scaling factors in local variables and eliminating other local variables. All answers are bitwise identical. --- .../solo_driver/MESO_surface_forcing.F90 | 25 ++--- .../solo_driver/MOM_surface_forcing.F90 | 105 +++++++++--------- 2 files changed, 67 insertions(+), 63 deletions(-) diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index f828513dae..cf59d577d8 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -27,9 +27,9 @@ module MESO_surface_forcing 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 [kg m-3]. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [Pa]. real, dimension(:,:), pointer :: & @@ -83,7 +83,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! toward [kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -142,7 +142,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! 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) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s * CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = US%m_to_Z*US%T_to_s * CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) ! vprec will be set later, if it is needed for salinity restoring. fluxes%vprec(i,j) = 0.0 @@ -169,14 +169,14 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & ! "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = US%R_to_kg_m3*CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (US%kg_m3_to_R*US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const) * & + ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const) + fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -191,14 +191,14 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. density_restore = 1030.0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) + US%kg_m3_to_R * (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -242,7 +242,7 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", units="Pa", & default=0.02) @@ -256,10 +256,9 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T), & fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & "The file with the SST toward which to restore in "//& diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 7224d68d48..79b3d2b0a5 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -83,7 +83,7 @@ module MOM_surface_forcing real :: Flux_const !< piston velocity for surface restoring [m s-1] real :: Flux_const_T !< piston velocity for surface temperature restoring [m s-1] real :: Flux_const_S !< piston velocity for surface salinity restoring [m s-1] - real :: latent_heat_fusion !< latent heat of fusion [J kg-1] + real :: latent_heat_fusion !< latent heat of fusion times scaling factors [J T m-2 R-1 Z-1 s-1 ~> J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" forcing real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" forcing @@ -542,7 +542,6 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [R L Z T-1 ~> Pa]. real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress ! units [R Z L T-2 Pa-1 ~> 1] - real :: Rho0_mks ! The mean density in MKS units [kg m-3] integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and montly cycles. integer :: time_lev ! The time level that is used for a field. @@ -554,7 +553,6 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - Rho0_mks = CS%Rho0 * US%R_to_kg_m3 call get_time(day, seconds, days) time_lev_daily = days - 365*floor(real(days) / 365.0) @@ -775,8 +773,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) ! anomalies when calculating restorative precipitation ! anomalies [ppt]. + real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling + ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. real :: rhoXcp ! reference density times heat capacity [J m-3 degC-1] - real :: Irho0 ! inverse of the Boussinesq reference density [m3 kg-1] integer :: time_lev_daily ! time levels to read for fields with daily cycle integer :: time_lev_monthly ! time levels to read for fields with monthly cycle @@ -788,9 +787,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s if (CS%use_temperature) rhoXcp = US%R_to_kg_m3*CS%Rho0 * fluxes%C_p - Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) ! Read the buoyancy forcing file call get_time(day, seconds, days) @@ -842,12 +841,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) G%Domain, timelevel=time_lev) do j=js,je ; do i=is,ie fluxes%latent(i,j) = -CS%latent_heat_vapor*temp(i,j) - fluxes%evap(i,j) = -US%kg_m3_to_R*US%m_to_Z*US%T_to_s*temp(i,j) + fluxes%evap(i,j) = -kg_m2_s_conversion*temp(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo else call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & - G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + G%Domain, timelevel=time_lev, scale=kg_m2_s_conversion) endif CS%evap_last_lev = time_lev @@ -902,9 +901,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select call MOM_read_data(CS%snow_file, CS%snow_var, & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=kg_m2_s_conversion) call MOM_read_data(CS%rain_file, CS%rain_var, & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=kg_m2_s_conversion) if (CS%archaic_OMIP_file) then do j=js,je ; do i=is,ie fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) @@ -919,20 +918,20 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) end select if (CS%archaic_OMIP_file) then call MOM_read_data(CS%runoff_file, CS%lrunoff_var, temp(:,:), & - G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + G%Domain, timelevel=time_lev, scale=kg_m2_s_conversion) do j=js,je ; do i=is,ie fluxes%lrunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo call MOM_read_data(CS%runoff_file, CS%frunoff_var, temp(:,:), & - G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + G%Domain, timelevel=time_lev, scale=kg_m2_s_conversion) do j=js,je ; do i=is,ie fluxes%frunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo else call MOM_read_data(CS%runoff_file, CS%lrunoff_var, fluxes%lrunoff(:,:), & - G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + G%Domain, timelevel=time_lev, scale=kg_m2_s_conversion) call MOM_read_data(CS%runoff_file, CS%frunoff_var, fluxes%frunoff(:,:), & - G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + G%Domain, timelevel=time_lev, scale=kg_m2_s_conversion) endif CS%runoff_last_lev = time_lev @@ -976,8 +975,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo endif ! time_lev /= CS%buoy_last_lev_read @@ -991,7 +990,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1002,8 +1001,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) else do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) + fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + (CS%G_Earth * CS%Flux_const / CS%Rho0) else fluxes%buoy(i,j) = 0.0 endif @@ -1053,8 +1052,9 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US SSS_mean ! A (mean?) salinity about which to normalize local salinity ! anomalies when calculating restorative precipitation ! anomalies [ppt]. + real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling + ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. - real :: Rho0_mks ! The mean density in MKS units [kg m-3] integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and montly cycles. @@ -1068,7 +1068,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - Rho0_mks = CS%Rho0 * US%R_to_kg_m3 + kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p @@ -1094,7 +1094,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! but evap is normally a positive quantity in the files fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - fluxes%evap(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*fluxes%evap(i,j) + fluxes%evap(i,j) = kg_m2_s_conversion*fluxes%evap(i,j) enddo ; enddo call data_override('OCN', 'sens', fluxes%sens(:,:), day, & @@ -1110,22 +1110,22 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) call data_override('OCN', 'snow', fluxes%fprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion call data_override('OCN', 'rain', fluxes%lprec(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion call data_override('OCN', 'runoff', fluxes%lrunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion call data_override('OCN', 'calving', fluxes%frunoff(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion - if (US%kg_m3_to_R*US%m_to_Z*US%T_to_s /= 1.0) then ; do j=js,je ; do i=is,ie - fluxes%lprec(i,j) = fluxes%lprec(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s - fluxes%fprec(i,j) = fluxes%fprec(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s - fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s - fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * US%kg_m3_to_R*US%m_to_Z*US%T_to_s + if (kg_m2_s_conversion /= 1.0) then ; do j=js,je ; do i=is,ie + fluxes%lprec(i,j) = fluxes%lprec(i,j) * kg_m2_s_conversion + fluxes%fprec(i,j) = fluxes%fprec(i,j) * kg_m2_s_conversion + fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * kg_m2_s_conversion + fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * kg_m2_s_conversion enddo ; enddo ; endif ! Read the SST and SSS fields for damping. @@ -1145,7 +1145,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*US%m_to_Z*US%T_to_s*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1156,8 +1156,8 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US else do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/Rho0_mks) + fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + (CS%G_Earth * CS%Flux_const / CS%Rho0) else fluxes%buoy(i,j) = 0.0 endif @@ -1189,8 +1189,8 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo @@ -1305,13 +1305,11 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by !! a previous surface_forcing_init call ! Local variables - real :: Rho0_mks ! The mean density in MKS units [kg m-3] real :: y, T_restore, S_restore integer :: i, j, is, ie, js, je call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Rho0_mks = CS%Rho0 * US%R_to_kg_m3 ! This case has no surface buoyancy forcing. if (CS%use_temperature) then @@ -1343,9 +1341,9 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((Rho0_mks * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const) * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * (US%R_to_kg_m3*US%Z_to_m*US%s_to_T) * & + ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) + fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else @@ -1358,8 +1356,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/Rho0_mks) + ! fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1412,6 +1410,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C type(time_type) :: Time_frc ! This include declares and sets the variable "version". # include "version_variable.h" + real :: flux_const_default ! The unscaled value of FLUX_CONST [m day-1] logical :: default_2018_answers character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1670,30 +1669,36 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) + "The latent heat of fusion.", default=hlf, & + units="J/kg", scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & "The latent heat of fusion.", units="J/kg", default=hlv) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, & + fail_if_missing=.true., unscaled=flux_const_default) if (CS%use_temperature) then call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & "The constant that relates the restoring surface temperature "//& "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - default=CS%Flux_const) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=1.0, & ! scale=US%m_to_Z*US%T_to_s, + default=flux_const_default) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & "The constant that relates the restoring surface salinity "//& "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - default=CS%Flux_const) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, & + default=flux_const_default) endif - ! Convert flux constants from m day-1 to m s-1. + !### Convert flux constants from m day-1 to m s-1. Folding these into the scaling + ! factors above could change a division into a multiply by a reciprocal, which could + ! change answers at the level of roundoff. CS%Flux_const = CS%Flux_const / 86400.0 CS%Flux_const_T = CS%Flux_const_T / 86400.0 CS%Flux_const_S = CS%Flux_const_S / 86400.0 From 8f3c126ba19f34665ef32acd18d16b259be4cf87 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Oct 2019 08:30:16 -0400 Subject: [PATCH 163/259] Rescaled FLUXCONST to [Z T-1] in eight modules Converted the units of FLUXCONST to [Z T-1] in eight modules for expanded dimensional consistency testing. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 25 ++++++++++--------- .../ice_solo_driver/MOM_surface_forcing.F90 | 20 +++++++-------- .../ice_solo_driver/user_surface_forcing.F90 | 16 ++++++------ .../solo_driver/MOM_surface_forcing.F90 | 6 ++--- .../solo_driver/Neverland_surface_forcing.F90 | 8 +++--- .../solo_driver/user_surface_forcing.F90 | 12 ++++----- src/user/BFB_surface_forcing.F90 | 12 ++++----- src/user/dumbbell_surface_forcing.F90 | 8 +++--- 8 files changed, 54 insertions(+), 53 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 40d336ec69..33dbbeb14a 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -113,7 +113,7 @@ module MOM_surface_forcing_gfdl !! salinity to a specified value. logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. - real :: Flux_const !< Piston velocity for surface restoring [m s-1] + real :: Flux_const !< Piston velocity for surface restoring [Z T-1 ~> m s-1] logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux 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 @@ -242,9 +242,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc real :: delta_sss ! temporary storage for sss diff from restoring value [ppt] real :: delta_sst ! temporary storage for sst diff from restoring value [degC] - real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling - !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. - real :: C_p ! heat capacity of seawater [J degC-1 kg-1] + real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling + ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. + real :: rhoXcp ! Reference density times heat capacity times unit scaling + ! factors [J T s-1 Z-1 m-2 degC-1 ~> J m-3 degC-1] 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) @@ -258,7 +259,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s - C_p = fluxes%C_p + if (CS%restore_temp) rhoXcp = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * CS%Rho0 * fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -355,7 +356,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc do j=js,je ; do i=is,ie delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*US%m_to_Z*US%T_to_s*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -377,7 +378,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const) * & + (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -405,7 +406,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc delta_sst = data_restore(i,j)- sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & - (US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + rhoXcp * delta_sst * CS%Flux_const ! W m-2 enddo ; enddo endif @@ -1350,8 +1351,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & default="salt_restore.nc") @@ -1398,8 +1399,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & default="temp_restore.nc") diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index ea3385e88e..89723ced24 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -99,7 +99,7 @@ module MOM_surface_forcing real :: Rho0 ! Boussinesq reference density [R ~> kg m-3] real :: G_Earth ! gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const ! piston velocity for surface restoring [m s-1] + real :: Flux_const ! piston velocity for surface restoring [Z T-1 ~> m s-1] real :: gust_const ! constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] logical :: read_gust_2d ! if true, use 2-dimensional gustiness supplied from a file @@ -745,8 +745,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & - ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - ((US%m_to_Z*US%T_to_s*CS%Rho0)*CS%Flux_const) * & + ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const) + fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -758,7 +758,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) + (CS%G_Earth * CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) else fluxes%buoy(i,j) = 0.0 endif @@ -877,9 +877,9 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then - fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & + fluxes%heat_restore(i,j) = G%mask2dT(i,j) * US%Z_to_m*US%s_to_T * & ((T_Restore - sfc_state%SST(i,j)) * (((US%R_to_kg_m3*CS%Rho0) * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - ((US%m_to_Z*US%T_to_s*CS%Rho0)*CS%Flux_const) * & + fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else @@ -892,8 +892,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) + ! fluxes%buoy(i,j) = US%kg_m3_to_R*(CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1090,8 +1090,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 if (trim(CS%buoy_config) == "linear") then diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 28d60c895a..4540833e09 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -81,7 +81,7 @@ module user_surface_forcing real :: Rho0 ! The density used in the Boussinesq ! approximation [R ~> kg m-3]. real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: Flux_const ! The restoring rate at the surface [m s-1]. + real :: Flux_const ! The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const ! A constant unresolved background gustiness ! that contributes to ustar [R Z L T-1 ~> Pa]. @@ -182,7 +182,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! toward [kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -257,9 +257,9 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -269,14 +269,14 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / (US%R_to_kg_m3*CS%Rho0) + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. density_restore = 1030.0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) + US%kg_m3_to_R*(density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -332,8 +332,8 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 endif diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 79b3d2b0a5..56d7d5a846 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -80,9 +80,9 @@ module MOM_surface_forcing real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< piston velocity for surface restoring [m s-1] + real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] real :: Flux_const_T !< piston velocity for surface temperature restoring [m s-1] - real :: Flux_const_S !< piston velocity for surface salinity restoring [m s-1] + real :: Flux_const_S !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] real :: latent_heat_fusion !< latent heat of fusion times scaling factors [J T m-2 R-1 Z-1 s-1 ~> J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" forcing @@ -1410,7 +1410,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C type(time_type) :: Time_frc ! This include declares and sets the variable "version". # include "version_variable.h" - real :: flux_const_default ! The unscaled value of FLUX_CONST [m day-1] + real :: flux_const_default ! The unscaled value of FLUXCONST [m day-1] logical :: default_2018_answers character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index d1fe150767..6bfcef515b 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -34,7 +34,7 @@ module Neverland_surface_forcing real :: Rho0 !< The density used in the Boussinesq !! approximation [kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: flux_const !< The restoring rate at the surface [m s-1]. + real :: flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real, dimension(:,:), pointer :: & buoy_restore(:,:) => NULL() !< The pattern to restore buoyancy to. character(len=200) :: inputdir !< The directory where NetCDF input files are. @@ -197,7 +197,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! so that the original (unmodified) version is not accidentally used. ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. @@ -262,8 +262,8 @@ subroutine Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) ! Convert CS%flux_const from m day-1 to m s-1. CS%flux_const = CS%flux_const / 86400.0 endif diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 1831503f1f..caf862f097 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -35,7 +35,7 @@ module user_surface_forcing logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 s-2 ~> m s-2]. - real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [R L Z T-1 ~> Pa]. @@ -209,9 +209,9 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -221,7 +221,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / Rho0_mks + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / Rho0_mks do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. @@ -284,8 +284,8 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 endif diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index bce0698240..b0a0482942 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -29,7 +29,7 @@ module BFB_surface_forcing logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [Pa]. real :: SST_s !< SST at the southern edge of the linear forcing ramp [degC] @@ -134,9 +134,9 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const)) * & (Temp_restore - state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*CS%Rho0*CS%Flux_const)) * & ((Salin_restore - state%SSS(i,j)) / (0.5 * (Salin_restore + state%SSS(i,j)))) enddo ; enddo else @@ -146,7 +146,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * US%m_to_Z*US%T_to_s*CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 Temp_restore = 0.0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential @@ -233,8 +233,8 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 endif diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 4f9483d7e5..4b73bb18aa 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -29,7 +29,7 @@ module dumbbell_surface_forcing logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [Pa]. real :: slp_amplitude !< The amplitude of pressure loading [Pa] applied @@ -124,7 +124,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. if (CS%forcing_mask(i,j)>0.) then - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*US%m_to_Z*US%T_to_s*CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*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)))) endif @@ -238,8 +238,8 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) + "velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 From 3b6ccd8c291827699c879c0d109be56775f29d10 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Oct 2019 09:12:18 -0400 Subject: [PATCH 164/259] Rescaled RHO0 to [R] in four modules Converted the units of RHO0 to [R] in four modules for expanded dimensional consistency testing. All answers are bitwise identical. --- .../ice_solo_driver/user_surface_forcing.F90 | 3 +- .../solo_driver/Neverland_surface_forcing.F90 | 11 +++---- src/user/BFB_surface_forcing.F90 | 31 ++++++++++--------- src/user/dumbbell_surface_forcing.F90 | 6 ++-- 4 files changed, 25 insertions(+), 26 deletions(-) diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 4540833e09..57accf2ef5 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -78,8 +78,7 @@ module user_surface_forcing 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 [R ~> kg m-3]. + real :: Rho0 ! The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const ! The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const ! A constant unresolved background gustiness diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 6bfcef515b..e6b7152e86 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -31,8 +31,7 @@ module Neverland_surface_forcing logical :: use_temperature !< If true, use temperature and salinity. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. - real :: Rho0 !< The density used in the Boussinesq - !! approximation [kg m-3]. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real, dimension(:,:), pointer :: & @@ -108,7 +107,7 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) ! forces%ustar(i,j) = G%mask2dT(i,j) * sqrt((CS%gust_const + & ! sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & ! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * & -! (US%L_to_Z * US%R_to_kg_m3/CS%Rho0) ) +! (US%L_to_Z / CS%Rho0) ) ! enddo ; enddo ; endif end subroutine Neverland_wind_forcing @@ -148,7 +147,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. ! Local variables real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. real :: density_restore ! De integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -204,7 +203,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) density_restore = 1030.0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) + US%kg_m3_to_R*(density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -248,7 +247,7 @@ subroutine Neverland_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & ! "The background gustiness in the winds.", units="Pa", & ! default=0.02) diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index b0a0482942..6283f07490 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -27,7 +27,7 @@ module BFB_surface_forcing 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 [kg m-3]. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness @@ -36,7 +36,7 @@ module BFB_surface_forcing real :: SST_n !< SST at the northern edge of the linear forcing ramp [degC] real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degLat] real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degLat] - real :: drho_dt !< Rate of change of density with temperature [kg m-3 degC-1]. + real :: drho_dt !< Rate of change of density with temperature [R degC-1 ~> kg m-3 degC-1]. !! Note that temperature is being used as a dummy variable here. !! All temperatures are converted into density. @@ -65,10 +65,11 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) real :: Temp_restore ! The temperature that is being restored toward [degC]. real :: Salin_restore ! The salinity that is being restored toward [ppt]. real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + ! toward [R ~> kg m-3]. + real :: rhoXcp ! Reference density times heat capacity times unit scaling + ! factors [J T s-1 Z-1 m-2 degC-1 ~> J m-3 degC-1] real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -127,16 +128,16 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & ((Salin_restore - state%SSS(i,j)) / (0.5 * (Salin_restore + state%SSS(i,j)))) enddo ; enddo else @@ -163,7 +164,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) density_restore = Temp_restore*CS%drho_dt + CS%Rho0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - state%sfc_density(i,j)) + (density_restore - US%kg_m3_to_R*state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -205,22 +206,22 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "LFR_SLAT", CS%lfrslat, & "Southern latitude where the linear forcing ramp begins.", & - units="degrees", default = 20.0) + units="degrees", default=20.0) call get_param(param_file, mdl, "LFR_NLAT", CS%lfrnlat, & "Northern latitude where the linear forcing ramp ends.", & - units="degrees", default = 40.0) + units="degrees", default=40.0) call get_param(param_file, mdl, "SST_S", CS%SST_s, & "SST at the southern edge of the linear forcing ramp.", & - units="C", default = 20.0) + units="C", default=20.0) call get_param(param_file, mdl, "SST_N", CS%SST_n, & "SST at the northern edge of the linear forcing ramp.", & - units="C", default = 10.0) + units="C", default=10.0) call get_param(param_file, mdl, "DRHO_DT", CS%drho_dt, & "The rate of change of density with temperature.", & - units="kg m-3 K-1", default = -0.2) + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", units="Pa", & default=0.02) diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 4b73bb18aa..d6d6dea11a 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -27,7 +27,7 @@ module dumbbell_surface_forcing 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 [kg m-3]. + real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness @@ -124,7 +124,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. if (CS%forcing_mask(i,j)>0.) then - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (US%kg_m3_to_R*CS%Rho0*CS%Flux_const)) * & + 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)))) endif @@ -214,7 +214,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) 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) From 838bc41abe2fef16cb9bbe813e5336cb488f44d0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Oct 2019 09:14:00 -0400 Subject: [PATCH 165/259] Removed unused code in MOM_barotropic.F90 Removed unnecessary commented out code and an unused variable in MOM_barotropic.F90. All answers are bitwise identical. --- src/core/MOM_barotropic.F90 | 41 ++++++++++++++----------------------- 1 file changed, 15 insertions(+), 26 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0fdd8c935d..fbadddd4d4 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -159,7 +159,6 @@ module MOM_barotropic type(BT_OBC_type) :: BT_OBC !< A structure with all of this modules fields !! for applying open boundary conditions. - real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. real :: dtbt !< The barotropic time step [s]. real :: dtbt_fraction !< The fraction of the maximum time-step that !! should used. The default is 0.98. @@ -724,7 +723,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, bebt = CS%bebt be_proj = CS%bebt mass_accel_to_Z = 1.0 / GV%Rho0 - mass_to_Z = US%m_to_Z / (GV%Rho0) + mass_to_Z = US%m_to_Z / GV%Rho0 !--- setup the weight when computing vbt_trans and ubt_trans if (project_velocity) then @@ -4326,30 +4325,20 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! Calculate other constants which are used for btstep. - ! The following is only valid with the Boussinesq approximation. -! if (GV%Boussinesq) then - do j=js,je ; do I=is-1,ie - if (G%mask2dCu(I,j)>0.) then - CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (G%bathyT(i+1,j) + G%bathyT(i,j)) - else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless - CS%IDatu(I,j) = 0. - endif - enddo ; enddo - do J=js-1,je ; do i=is,ie - if (G%mask2dCv(i,J)>0.) then - CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (G%bathyT(i,j+1) + G%bathyT(i,j)) - else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless - CS%IDatv(i,J) = 0. - endif - enddo ; enddo -! else -! do j=js,je ; do I=is-1,ie -! CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (US%R_to_kg_m3*GV%Rho0*(G%bathyT(i+1,j) + G%bathyT(i,j))) -! enddo ; enddo -! do J=js-1,je ; do i=is,ie -! CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (US%R_to_kg_m3*GV%Rho0*(G%bathyT(i,j+1) + G%bathyT(i,j))) -! enddo ; enddo -! endif + do j=js,je ; do I=is-1,ie + if (G%mask2dCu(I,j)>0.) then + CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (G%bathyT(i+1,j) + G%bathyT(i,j)) + else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless + CS%IDatu(I,j) = 0. + endif + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (G%mask2dCv(i,J)>0.) then + CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (G%bathyT(i,j+1) + G%bathyT(i,j)) + else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless + CS%IDatv(i,J) = 0. + endif + enddo ; enddo call find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo=1) if (CS%bound_BT_corr) then From 35b884da81023eeadbb7e42c11baa394a2a8c57f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Oct 2019 10:24:31 -0400 Subject: [PATCH 166/259] Fixed a recently added bug in insert_brine Fixed a recently bug in insert_brine that was introduced yesteray with MOM6 commit 965c2c2. This bug is a double inclusion of US%s_to_T, so technically it does not change answers, just breaks dimensional consistency testing. For some reason the impacted code was not triggered by the MOM6-examples test cases. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 9ef154ba8d..cd97439612 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -429,7 +429,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) salt(:)=0.0 ; dzbr(:)=0.0 do i=is,ie ; if (G%mask2dT(i,j) > 0.) then - salt(i) = US%s_to_T*dt * (1000. * US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%salt_flux(i,j)) + salt(i) = US%s_to_T*dt * (1000. * US%R_to_kg_m3*US%Z_to_m*fluxes%salt_flux(i,j)) endif ; enddo do k=1,nz From 5484ab033c66902aadb97deed91b16464fc6f431 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Oct 2019 21:16:22 -0400 Subject: [PATCH 167/259] +Pass timestep to insert_brine in units of [T] Pass timestep to applyBoundaryFluxesInOut and insert_brine in units of [T]. All answers are bitwise identical, but the units of arguments to two public subroutines have rescaled dimensions. --- .../vertical/MOM_diabatic_aux.F90 | 31 +++++++++---------- .../vertical/MOM_diabatic_driver.F90 | 12 +++---- 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index cd97439612..b98130515f 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -79,7 +79,7 @@ module MOM_diabatic_aux ! Optional diagnostic arrays real, allocatable, dimension(:,:) :: createdH !< The amount of volume added in order to - !! avoid grounding [m s-1] + !! avoid grounding [H T-1 ~> m s-1] real, allocatable, dimension(:,:,:) :: penSW_diag !< Heating in a layer from convergence of !! penetrative SW [W m-2] real, allocatable, dimension(:,:,:) :: penSWflux_diag !< Penetrative SW flux at base of grid @@ -382,7 +382,7 @@ end subroutine adjust_salt !> Insert salt from brine rejection into the first layer below the mixed layer !! which both contains mass and in which the change in layer density remains !! stable after the addition of salt via brine rejection. -subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) +subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_lay) 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)), & @@ -394,7 +394,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) integer, intent(in) :: nkmb !< The number of layers in the mixed and buffer layers type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous !! call to diabatic_aux_init - real, intent(in) :: dt !< The thermodynamic time step [s]. + real, intent(in) :: dt_in_T !< The thermodynamic time step [T ~> s]. integer, intent(in) :: id_brine_lay !< The handle for a diagnostic of !! which layer receivees the brine. @@ -429,7 +429,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) salt(:)=0.0 ; dzbr(:)=0.0 do i=is,ie ; if (G%mask2dT(i,j) > 0.) then - salt(i) = US%s_to_T*dt * (1000. * US%R_to_kg_m3*US%Z_to_m*fluxes%salt_flux(i,j)) + salt(i) = dt_in_T * (1000. * US%R_to_kg_m3*US%Z_to_m*fluxes%salt_flux(i,j)) endif ; enddo do k=1,nz @@ -845,7 +845,7 @@ end subroutine diagnoseMLDbyDensityDifference !> Update the thickness, temperature, and salinity due to thermodynamic !! boundary forcing (contained in fluxes type) applied to h, tv%T and tv%S, !! and calculate the TKE implications of this heating. -subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, tv, & +subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, h, tv, & aggregate_FW_forcing, evap_CFL_limit, & minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & SkinBuoyFlux ) @@ -853,7 +853,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: dt !< Time-step over which forcing is applied [s] + real, intent(in) :: dt_in_T !< Time-step over which forcing is applied [T ~> s] type(forcing), intent(inout) :: fluxes !< Surface fluxes container type(optics_type), pointer :: optics !< Optical properties container integer, intent(in) :: nsw !< The number of frequency bands of penetrating @@ -882,7 +882,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Local variables integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) - real :: H_limit_fluxes, IforcingDepthScale, Idt + real :: H_limit_fluxes, IforcingDepthScale + real :: Idt real :: dThickness, dTemp, dSalt real :: fractionOfForcing, hOld, Ithickness real :: RivermixConst ! A constant used in implementing river mixing [Pa s]. @@ -925,7 +926,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] real, dimension(maxGroundings) :: hGrounding real :: Temp_in, Salin_in - real :: dt_in_T ! The time step converted to T units [T ~> s] real :: g_Hconv2 ! A conversion factor for use in the TKE calculation ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. real :: GoRho ! g_Earth times a unit conversion factor divided by density @@ -942,8 +942,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (.not.associated(fluxes%sw)) return #define _OLD_ALG_ - dt_in_T = dt * US%s_to_T - Idt = 1.0/dt + Idt = 1.0/ (US%T_to_s*dt_in_T) calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) @@ -1056,14 +1055,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! but do change answers. !----------------------------------------------------------------------------------------- if (calculate_buoyancy) then - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, US%T_to_s*dt_in_T, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW, & net_Heat_rate=netheat_rate, net_salt_rate=netsalt_rate, & netmassinout_rate=netmassinout_rate, pen_sw_bnd_rate=pen_sw_bnd_rate) else - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, US%T_to_s*dt_in_T, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW) @@ -1133,9 +1132,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (GV%Boussinesq) then - RivermixConst = -0.5*(CS%rivermix_depth*US%s_to_T*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + RivermixConst = -0.5*(CS%rivermix_depth*dt_in_T) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 else - RivermixConst = -0.5*(CS%rivermix_depth*US%s_to_T*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) + RivermixConst = -0.5*(CS%rivermix_depth*dt_in_T) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) endif cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) @@ -1258,7 +1257,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t hGrounding(numberOfGroundings) = netMassIn(i)+netMassOut(i) endif !$OMP end critical - if (CS%id_createdH>0) CS%createdH(i,j) = CS%createdH(i,j) - (netMassIn(i)+netMassOut(i))/dt + if (CS%id_createdH>0) CS%createdH(i,j) = CS%createdH(i,j) - (netMassIn(i)+netMassOut(i))/dt_in_T endif enddo ! i @@ -1485,7 +1484,7 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori if (useALEalgorithm) then CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & Time, "The volume flux added to stop the ocean from drying out and becoming negative in depth", & - "m s-1") + "m s-1", conversion=GV%H_to_m*US%s_to_T) if (CS%id_createdH>0) allocate(CS%createdH(isd:ied,jsd:jed)) ! diagnostic for heating of a grid cell from convergence of SW heat into the cell diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index a529f60abc..561192dab1 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -825,7 +825,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%use_energetic_PBL) then skinbuoyflux(:,:) = 0.0 - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) @@ -891,7 +891,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif else - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & CS%evap_CFL_limit, CS%minimum_forcing_depth) @@ -1556,7 +1556,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%use_energetic_PBL) then skinbuoyflux(:,:) = 0.0 - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) @@ -1610,7 +1610,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif else - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & CS%evap_CFL_limit, CS%minimum_forcing_depth) @@ -2086,7 +2086,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Hml, CS%aggregate_FW_forcing, dt_in_T, last_call=.false.) if (CS%salt_reject_below_ML) & call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, & - dt*CS%ML_mix_first, CS%id_brine_lay) + dt_in_T*CS%ML_mix_first, CS%id_brine_lay) else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_in_T, eaml, ebml, & @@ -2479,7 +2479,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Hml, CS%aggregate_FW_forcing, dt_in_T, last_call=.true.) if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, US%T_to_s*dt_mix, & + call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, dt_mix, & CS%id_brine_lay) ! Keep salinity from falling below a small but positive threshold. From 3f693500160ab14e51674f0163d1651f798511fd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Oct 2019 21:37:28 -0400 Subject: [PATCH 168/259] +Pass timestep to extractFluxes1d in units of [T] Pass timestep to extractFluxes1d and extractFluxes2d in units of [T]. All answers are bitwise identical, but the units of arguments to two public subroutines have rescaled dimensions. --- src/core/MOM_forcing_type.F90 | 26 +++++++++---------- .../vertical/MOM_bulk_mixed_layer.F90 | 5 +--- .../vertical/MOM_diabatic_aux.F90 | 4 +-- 3 files changed, 15 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index db15bf1cfa..e98eb8a217 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -336,10 +336,10 @@ module MOM_forcing_type !! for optimization purposes. The 2d (i,j) wrapper is the next subroutine below. !! This routine multiplies fluxes by dt, so that the result is an accumulation of fluxes !! over a time step. -subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & +subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent, & - h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & - aggregate_FW, nonpenSW, netmassInOut_rate, net_Heat_Rate, & + h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & + aggregate_FW, nonpenSW, netmassInOut_rate, net_Heat_Rate, & net_salt_rate, pen_sw_bnd_Rate, skip_diags) type(ocean_grid_type), intent(in) :: G !< ocean grid structure @@ -350,7 +350,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, type(optics_type), pointer :: optics !< pointer to optics integer, intent(in) :: nsw !< number of bands of penetrating SW integer, intent(in) :: j !< j-index to work on - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt_in_T !< The time step for these fluxes [T ~> s] real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes !! are scaled away [H ~> m or kg m-2] logical, intent(in) :: useRiverHeatContent !< logical for river heat content @@ -414,7 +414,6 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, real :: W_m2_to_H_T ! converts W/m^2 to H degC T-1 [degC H T-1 W-2 m2 ~> degC m3 J-1 or degC kg J-1] real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature ! change [W m-2 degC-1 T R-1 Z-1 ~> J kg degC] - real :: dt_in_T ! The timestep [T ~> s] real :: I_Cp ! 1.0 / C_p [kg decC J-1] logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays character(len=200) :: mesg @@ -438,7 +437,6 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, Ih_limit = 1.0 / FluxRescaleDepth RZ_T_to_W_m2_degC = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T - dt_in_T = dt * US%s_to_T I_Cp = 1.0 / fluxes%C_p W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * fluxes%C_p) @@ -697,10 +695,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, if (associated(fluxes%heat_content_massin)) then if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" - fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / dt + fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) else ! net is "out" fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & - T(i,1) * GV%H_to_kg_m2 / dt + T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) endif else fluxes%heat_content_massin(i,j) = 0. @@ -712,10 +710,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, if (associated(fluxes%heat_content_massout)) then if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" - fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / dt + fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) else ! net is "out" fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & - T(i,1) * GV%H_to_kg_m2 / dt + T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) endif else fluxes%heat_content_massout(i,j) = 0.0 @@ -806,7 +804,7 @@ end subroutine extractFluxes1d !> 2d wrapper for 1d extract fluxes from surface fluxes type. !! This subroutine extracts fluxes from the surface fluxes type. It multiplies the !! fluxes by dt, so that the result is an accumulation of the fluxes over a time step. -subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, & +subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt_in_T, FluxRescaleDepth, & useRiverHeatContent, useCalvingHeatContent, h, T, & netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & aggregate_FW) @@ -817,7 +815,7 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, type(forcing), intent(inout) :: fluxes !< structure containing pointers to forcing. type(optics_type), pointer :: optics !< pointer to optics integer, intent(in) :: nsw !< number of bands of penetrating SW - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt_in_T !< The time step for these fluxes [T ~> s] real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes !! are scaled away [H ~> m or kg m-2] logical, intent(in) :: useRiverHeatContent !< logical for river heat content @@ -857,7 +855,7 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, !$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & !$OMP aggregate_FW) do j=G%jsc, G%jec - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& h(:,j,:), T(:,j,:), netMassInOut(:,j), netMassOut(:,j), & net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW) @@ -932,7 +930,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! netSalt = salt via surface fluxes [ppt H s-1 ~> ppt m s-1 or gSalt m-2 s-1] ! Note that unlike other calls to extractFLuxes1d() that return the time-integrated flux ! this call returns the rate because dt=1 - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt*US%s_to_T, & depthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & h(:,j,:), Temp(:,j,:), netH, netEvap, netHeatMinusSW, & netSalt, penSWbnd, tv, .false., skip_diags=skip_diags) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index e09b21f251..d525cf477f 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -347,7 +347,6 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, real :: absf_x_H ! The absolute value of f times the mixed layer thickness [Z T-1 ~> m s-1]. real :: kU_star ! Ustar times the Von Karmen constant [Z T-1 ~> m s-1]. -! real :: dt_in_T ! Time increment in time units [T ~> s]. real :: dt__diag ! A recaled copy of dt_diag (if present) or dt [T ~> s]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. @@ -370,8 +369,6 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, Inkml = 1.0 / REAL(CS%nkml) if (CS%nkml > 1) Inkmlm1 = 1.0 / REAL(CS%nkml-1) -! dt_in_T = dt * US%s_to_T - Irho0 = 1.0 / (GV%Rho0) dt__diag = dt_in_T ; if (present(dt_diag)) dt__diag = dt_diag Idt_diag = 1.0 / (dt__diag) @@ -533,7 +530,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, ! net_heat = heat via surface fluxes [degC H ~> degC m or degC kg m-2] ! net_salt = salt via surface fluxes [ppt H ~> dppt m or gSalt m-2] ! Pen_SW_bnd = components to penetrative shortwave radiation - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, US%T_to_s*dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & CS%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) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index b98130515f..3ace76c705 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1055,14 +1055,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! but do change answers. !----------------------------------------------------------------------------------------- if (calculate_buoyancy) then - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, US%T_to_s*dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW, & net_Heat_rate=netheat_rate, net_salt_rate=netsalt_rate, & netmassinout_rate=netmassinout_rate, pen_sw_bnd_rate=pen_sw_bnd_rate) else - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, US%T_to_s*dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW) From ecf58131d5d74e26cd20e160cfe7a9c7d0bfe54f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 7 Oct 2019 13:56:53 -0400 Subject: [PATCH 169/259] +Pass timestep to thickness_diffuse in units of [T] Pass timestep to thickness_diffuse and mixedlayer_restrat in units of [T]. All answers are bitwise identical, but the units of arguments to two public subroutines have rescaled dimensions. --- src/core/MOM.F90 | 6 +++--- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 8 ++++---- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 6 ++---- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b490311cf2..735ad3bdf4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -923,7 +923,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, US%s_to_T*dt_thermo, G, GV, US, & 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)) @@ -996,7 +996,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (associated(CS%VarMix)) & call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, US%s_to_T*dt, G, GV, US, & 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) @@ -1013,7 +1013,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) 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, CS%uhtr, CS%vhtr, CS%tv, forces, US%s_to_T*dt, CS%visc%MLD, & CS%VarMix, G, GV, US, 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)) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 855e0518f4..d0a67aba77 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -88,7 +88,7 @@ module MOM_mixed_layer_restrat !> Driver for the mixed-layer restratification parameterization. !! The code branches between two different implementations depending !! on whether the bulk-mixed layer or a general coordinate are in use. -subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt_in_T, MLD, VarMix, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -99,7 +99,7 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, !! [H L2 ~> 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 [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the !! PBL scheme [H ~> m or kg m-2] type(VarMix_CS), pointer :: VarMix !< Container for derived fields @@ -109,9 +109,9 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, "Module must be initialized before it is used.") if (GV%nkml>0) then - call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, US%s_to_T*dt, G, GV, US, CS) + call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, CS) else - call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, US%s_to_T*dt, MLD, VarMix, G, GV, US, CS) + call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD, VarMix, G, GV, US, CS) endif end subroutine mixedlayer_restrat diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ecc31ebd42..66f31ac9c6 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -96,7 +96,7 @@ module MOM_thickness_diffuse !> Calculates thickness diffusion coefficients and applies thickness diffusion to layer !! thicknesses, h. Diffusivities are limited to ensure stability. !! Also returns along-layer mass fluxes used in the continuity equation. -subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS) +subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt_in_T, G, GV, US, MEKE, VarMix, CDp, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -106,7 +106,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux !! [L2 H ~> m3 or kg] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] type(MEKE_type), pointer :: MEKE !< MEKE control structure type(VarMix_CS), pointer :: VarMix !< Variable mixing coefficients type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation @@ -141,7 +141,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] - real :: dt_in_T ! Time increment [T ~> s] logical :: use_VarMix, Resoln_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz @@ -158,7 +157,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke h_neglect = GV%H_subroundoff - dt_in_T = US%s_to_T*dt if (associated(MEKE)) then if (associated(MEKE%GM_src)) then From d5ee19a19d2f8573e5d0981854f08a87d2e0315a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 7 Oct 2019 13:57:17 -0400 Subject: [PATCH 170/259] Store timestep in [T} in sum_output_CS Changed the name and units of the timestep element in the sum_output_CS to work with units of [T]. Also combined mass flux scaling factors into a local variable in accumulate_net_input for simplification. All answers are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 46 ++++++++++++++++-------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index ceb004a36e..9d80f36b93 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -98,7 +98,7 @@ module MOM_sum_output type(EFP_type) :: heat_prev_EFP !< An extended fixed point version of heat_prev type(EFP_type) :: salt_prev_EFP !< An extended fixed point version of salt_prev type(EFP_type) :: mass_prev_EFP !< An extended fixed point version of mass_prev - real :: dt !< The baroclinic dynamics time step [s]. + real :: dt_in_T !< The baroclinic dynamics time step [T ~> s]. type(time_type) :: energysavedays !< The interval between writing the energies !! and other integral quantities of the run. @@ -179,9 +179,9 @@ subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) - call get_param(param_file, mdl, "DT", CS%dt, & - "The (baroclinic) dynamics time step.", units="s", & - fail_if_missing=.true.) + call get_param(param_file, mdl, "DT", CS%dt_in_T, & + "The (baroclinic) dynamics time step.", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "MAXTRUNC", CS%maxtrunc, & "The run will be stopped, and the day set to a very "//& "large value if the velocity is truncated more than "//& @@ -716,21 +716,21 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ max_CFL(1:2) = 0.0 do k=1,nz ; do j=js,je ; do I=Isq,Ieq if (u(I,j,k) < 0.0) then - CFL_trans = (-u(I,j,k) * US%s_to_T*CS%dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + CFL_trans = (-u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else - CFL_trans = (u(I,j,k) * US%s_to_T*CS%dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + CFL_trans = (u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i,j)) endif - CFL_lin = abs(u(I,j,k) * US%s_to_T*CS%dt) * G%IdxCu(I,j) + CFL_lin = abs(u(I,j,k) * CS%dt_in_T) * G%IdxCu(I,j) max_CFL(1) = max(max_CFL(1), CFL_trans) max_CFL(2) = max(max_CFL(2), CFL_lin) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie if (v(i,J,k) < 0.0) then - CFL_trans = (-v(i,J,k) * US%s_to_T*CS%dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + CFL_trans = (-v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else - CFL_trans = (v(i,J,k) * US%s_to_T*CS%dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + CFL_trans = (v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j)) endif - CFL_lin = abs(v(i,J,k) * US%s_to_T*CS%dt) * G%IdyCv(i,J) + CFL_lin = abs(v(i,J,k) * CS%dt_in_T) * G%IdyCv(i,J) max_CFL(1) = max(max_CFL(1), CFL_trans) max_CFL(2) = max(max_CFL(2), CFL_lin) enddo ; enddo ; enddo @@ -962,6 +962,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) real :: heat_input ! The total heat added by boundary fluxes, integrated ! over a time step and summed over space [J]. real :: C_p ! The heat capacity of seawater [J degC-1 kg-1]. + real :: dt_in_T ! Time increment [T ~> s] + real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] type(EFP_type) :: & FW_in_EFP, & ! Extended fixed point version of FW_input [kg] @@ -973,12 +975,14 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec C_p = fluxes%C_p + RZL2_to_kg = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m + dt_in_T = US%s_to_T*dt FW_in(:,:) = 0.0 ; FW_input = 0.0 if (associated(fluxes%evap)) then if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie - FW_in(i,j) = G%US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*dt*G%areaT(i,j)*(fluxes%evap(i,j) + & + FW_in(i,j) = RZL2_to_kg * dt_in_T*G%areaT(i,j)*(fluxes%evap(i,j) + & (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j)) + & (fluxes%fprec(i,j) + fluxes%frunoff(i,j)))) enddo ; enddo @@ -989,7 +993,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) endif if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie - FW_in(i,j) = FW_in(i,j) + G%US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*dt * & + FW_in(i,j) = FW_in(i,j) + RZL2_to_kg*dt_in_T * & G%areaT(i,j) * fluxes%seaice_melt(i,j) enddo ; enddo ; endif @@ -997,18 +1001,18 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (CS%use_temperature) then if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*G%US%L_to_m**2*G%areaT(i,j) * (fluxes%sw(i,j) + & + heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j) * (fluxes%sw(i,j) + & (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*G%US%L_to_m**2*G%areaT(i,j) * fluxes%seaice_melt_heat(i,j) + heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j) * fluxes%seaice_melt_heat(i,j) enddo ; enddo ; endif ! smg: new code ! include heat content from water transport across ocean surface ! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie -! heat_in(i,j) = heat_in(i,j) + dt*G%US%L_to_m**2*G%areaT(i,j) * & +! heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j) * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) & ! + (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) & ! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & @@ -1018,7 +1022,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! smg: old code if (associated(tv%TempxPmE)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (C_p * G%US%L_to_m**2*G%areaT(i,j)) * tv%TempxPmE(i,j) + heat_in(i,j) = heat_in(i,j) + (C_p * US%L_to_m**2*G%areaT(i,j)) * tv%TempxPmE(i,j) enddo ; enddo elseif (associated(fluxes%evap)) then do j=js,je ; do i=is,ie @@ -1030,23 +1034,23 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! The following heat sources may or may not be used. if (associated(tv%internal_heat)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (C_p * G%US%L_to_m**2*G%areaT(i,j)) * & + heat_in(i,j) = heat_in(i,j) + (C_p * US%L_to_m**2*G%areaT(i,j)) * & tv%internal_heat(i,j) enddo ; enddo endif if (associated(tv%frazil)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + G%US%L_to_m**2*G%areaT(i,j) * tv%frazil(i,j) + heat_in(i,j) = heat_in(i,j) + US%L_to_m**2*G%areaT(i,j) * tv%frazil(i,j) enddo ; enddo ; endif if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*G%US%L_to_m**2*G%areaT(i,j)*fluxes%heat_added(i,j) + heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j)*fluxes%heat_added(i,j) enddo ; enddo ; endif ! if (associated(sfc_state%sw_lost)) then ; do j=js,je ; do i=is,ie -! heat_in(i,j) = heat_in(i,j) - G%US%L_to_m**2*G%areaT(i,j) * sfc_state%sw_lost(i,j) +! heat_in(i,j) = heat_in(i,j) - US%L_to_m**2*G%areaT(i,j) * sfc_state%sw_lost(i,j) ! enddo ; enddo ; endif if (associated(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie ! convert salt_flux from kg (salt)/(m^2 s) to ppt * [m s-1]. - salt_in(i,j) = G%US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T*dt * & + salt_in(i,j) = RZL2_to_kg * dt_in_T * & G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) enddo ; enddo ; endif endif From a4da5929c1a8d478b20903bc1e52a3ab706f763d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 11:01:07 -0400 Subject: [PATCH 171/259] +Rescaled the units of fluxes%heat_content_... vars +Rescaled the units of the 9 fluxes%heat_content_... variables to units of [J kg-1 R Z T-1], and of tv%TempxPmE to units of [degC R Z] for greater dimensional consistency testing and for code simplification. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 4 +- .../ice_solo_driver/MOM_surface_forcing.F90 | 2 +- .../mct_driver/mom_surface_forcing_mct.F90 | 2 +- .../mom_surface_forcing_nuopc.F90 | 2 +- src/core/MOM.F90 | 2 +- src/core/MOM_forcing_type.F90 | 164 ++++++++++-------- src/core/MOM_variables.F90 | 4 +- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/diagnostics/MOM_sum_output.F90 | 4 +- .../vertical/MOM_bulk_mixed_layer.F90 | 16 +- .../vertical/MOM_diabatic_aux.F90 | 27 +-- 11 files changed, 127 insertions(+), 102 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 33dbbeb14a..08a09dbe23 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -464,13 +464,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc endif if (associated(IOB%runoff_hflx)) then - fluxes%heat_content_lrunoff(i,j) = IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%runoff_hflx(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff_hflx', G) endif if (associated(IOB%calving_hflx)) then - fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%calving_hflx(i-i0,j-j0), G%mask2dT(i,j), i, j, 'calving_hflx', G) endif diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 89723ced24..b2e26b0c66 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -731,7 +731,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + fluxes%heat_content_lrunoff(i,j) = fluxes%C_p * & fluxes%lrunoff(i,j)*sfc_state%SST(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*hlf diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index fa1dfbce5c..5cb31b50b9 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -458,7 +458,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) if (associated(IOB%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) ! longwave radiation, sum up and down (W/m2) if (associated(IOB%lw_flux)) & diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index e710b0be19..348ec53f07 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -458,7 +458,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & fluxes%heat_content_lrunoff(i,j) = IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion*IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%lw_flux)) & fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 735ad3bdf4..612862a616 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2926,7 +2926,7 @@ subroutine extract_surface_state(CS, sfc_state) if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%TempxPmE(i,j) = CS%tv%TempxPmE(i,j) + sfc_state%TempxPmE(i,j) = US%R_to_kg_m3*US%Z_to_m*CS%tv%TempxPmE(i,j) enddo ; enddo endif if (allocated(sfc_state%internal_heat) .and. associated(CS%tv%internal_heat)) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index e98eb8a217..47645eb57a 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -95,15 +95,16 @@ module MOM_forcing_type ! heat associated with water crossing ocean surface real, pointer, dimension(:,:) :: & - heat_content_cond => NULL(), & !< heat content associated with condensating water [W m-2] - heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [W m-2] (diagnostic) - heat_content_icemelt => NULL(), & !< heat content associated with snow/seaice melt/formation [W m-2] - heat_content_fprec => NULL(), & !< heat content associated with frozen precip [W m-2] - heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [W m-2] - heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [W m-2] - heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [W m-2] - heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [W m-2] - heat_content_massin => NULL() !< heat content associated with mass entering ocean [W m-2] + heat_content_cond => NULL(), & !< heat content associated with condensating water [J kg-1 R Z T-1 ~> W m-2] + heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [J kg-1 R Z T-1 ~> W m-2] + heat_content_icemelt => NULL(), & !< heat content associated with snow and seaice + !! melt and formation [J kg-1 R Z T-1 ~> W m-2] + heat_content_fprec => NULL(), & !< heat content associated with frozen precip [J kg-1 R Z T-1 ~> W m-2] + heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [J kg-1 R Z T-1 ~> W m-2] + heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [J kg-1 R Z T-1 ~> W m-2] + heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [J kg-1 R Z T-1 ~> W m-2] + heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [J kg-1 R Z T-1 ~> W m-2] + heat_content_massin => NULL() !< heat content associated with mass entering ocean [J kg-1 R Z T-1 ~> W m-2] ! salt mass flux (contributes to ocean mass only if non-Bouss ) real, pointer, dimension(:,:) :: & @@ -415,6 +416,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature ! change [W m-2 degC-1 T R-1 Z-1 ~> J kg degC] real :: I_Cp ! 1.0 / C_p [kg decC J-1] + real :: RZcp_to_H ! Unit convsersion factors divided by the heat capacity + ! [kg degC H R-1 Z-1 J-1 ~> degC m3 J-1 or kg degC J-1] logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays character(len=200) :: mesg integer :: is, ie, nz, i, k, n @@ -440,6 +443,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & I_Cp = 1.0 / fluxes%C_p W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * fluxes%C_p) + RZcP_to_H = 1.0 / (GV%H_to_RZ * fluxes%C_p) + is = G%isc ; ie = G%iec ; nz = G%ke calculate_diags = .true. @@ -600,16 +605,16 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! flux type). Runoff is otherwise added with a temperature of SST. if (useRiverHeatContent) then ! remove lrunoff*SST here, to counteract its addition elsewhere - net_heat(i) = (net_heat(i) + (scale*(dt_in_T * W_m2_to_H_T)) * fluxes%heat_content_lrunoff(i,j)) - & + net_heat(i) = (net_heat(i) + (scale*(dt_in_T * RZcP_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%lrunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. - !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(W_m2_to_H_T)) * fluxes%heat_content_lrunoff(i,j)) - & + !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*RZcP_to_H) * fluxes%heat_content_lrunoff(i,j)) - & ! (GV%RZ_to_H * (scale)) * fluxes%lrunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & - (I_Cp*US%T_to_s*fluxes%heat_content_lrunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*fluxes%lrunoff(i,j)*T(i,1)) + (I_Cp*fluxes%heat_content_lrunoff(i,j) - fluxes%lrunoff(i,j)*T(i,1)) endif endif @@ -617,16 +622,16 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! flux type). Calving is otherwise added with a temperature of SST. if (useCalvingHeatContent) then ! remove frunoff*SST here, to counteract its addition elsewhere - net_heat(i) = net_heat(i) + (scale*(dt_in_T * W_m2_to_H_T)) * fluxes%heat_content_frunoff(i,j) - & + net_heat(i) = net_heat(i) + (scale*(dt_in_T * RZcP_to_H)) * fluxes%heat_content_frunoff(i,j) - & (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%frunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. -! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*W_m2_to_H_T) * fluxes%heat_content_frunoff(i,j) - & +! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*RZcP_to_H) * fluxes%heat_content_frunoff(i,j) - & ! (GV%RZ_to_H * scale) * fluxes%frunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & - (I_Cp*US%T_to_s*fluxes%heat_content_frunoff(i,j) - US%R_to_kg_m3*US%Z_to_m*fluxes%frunoff(i,j)*T(i,1)) + (I_Cp*fluxes%heat_content_frunoff(i,j) - fluxes%frunoff(i,j)*T(i,1)) endif endif @@ -640,7 +645,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! When evap, lprec, or vprec > 0, then we know their heat content here ! via settings from inside of the appropriate config_src driver files. ! if (associated(fluxes%heat_content_lprec)) then -! net_heat(i) = net_heat(i) + scale * dt_in_T * W_m2_to_H_T * & +! net_heat(i) = net_heat(i) + scale * dt_in_T * RZcP_to_H * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) + & ! (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) + & ! (fluxes%heat_content_cond(i,j) + fluxes%heat_content_vprec(i,j)))))) @@ -695,10 +700,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & if (associated(fluxes%heat_content_massin)) then if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" - fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) + fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T else ! net is "out" fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & - T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) + T(i,1) * GV%H_to_RZ / dt_in_T endif else fluxes%heat_content_massin(i,j) = 0. @@ -710,10 +715,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & if (associated(fluxes%heat_content_massout)) then if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" - fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) + fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T else ! net is "out" - fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & - T(i,1) * GV%H_to_kg_m2 / (US%T_to_s*dt_in_T) + fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_RZ / dt_in_T endif else fluxes%heat_content_massout(i,j) = 0.0 @@ -729,7 +734,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! wait until MOM_diabatic_driver.F90. if (associated(fluxes%heat_content_lprec)) then if (fluxes%lprec(i,j) > 0.0) then - fluxes%heat_content_lprec(i,j) = RZ_T_to_W_m2_degC*fluxes%lprec(i,j)*T(i,1) + fluxes%heat_content_lprec(i,j) = fluxes%C_p*fluxes%lprec(i,j)*T(i,1) else fluxes%heat_content_lprec(i,j) = 0.0 endif @@ -740,7 +745,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! and until we do so fprec is treated like lprec and enters at SST. -AJA if (associated(fluxes%heat_content_fprec)) then if (fluxes%fprec(i,j) > 0.0) then - fluxes%heat_content_fprec(i,j) = RZ_T_to_W_m2_degC*fluxes%fprec(i,j)*T(i,1) + fluxes%heat_content_fprec(i,j) = fluxes%C_p*fluxes%fprec(i,j)*T(i,1) else fluxes%heat_content_fprec(i,j) = 0.0 endif @@ -749,7 +754,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Following lprec and fprec, water flux due to sea ice melt (seaice_melt) enters at SST - GMM if (associated(fluxes%heat_content_icemelt)) then if (fluxes%seaice_melt(i,j) > 0.0) then - fluxes%heat_content_icemelt(i,j) = RZ_T_to_W_m2_degC*fluxes%seaice_melt(i,j)*T(i,1) + fluxes%heat_content_icemelt(i,j) = fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) else fluxes%heat_content_icemelt(i,j) = 0.0 endif @@ -760,7 +765,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 if (associated(fluxes%heat_content_vprec)) then if (fluxes%vprec(i,j) > 0.0) then - fluxes%heat_content_vprec(i,j) = RZ_T_to_W_m2_degC*fluxes%vprec(i,j)*T(i,1) + fluxes%heat_content_vprec(i,j) = fluxes%C_p*fluxes%vprec(i,j)*T(i,1) else fluxes%heat_content_vprec(i,j) = 0.0 endif @@ -774,7 +779,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Condensation is assumed to drop into the ocean at the SST, just like lprec. if (associated(fluxes%heat_content_cond)) then if (fluxes%evap(i,j) > 0.0) then - fluxes%heat_content_cond(i,j) = RZ_T_to_W_m2_degC*fluxes%evap(i,j)*T(i,1) + fluxes%heat_content_cond(i,j) = fluxes%C_p*fluxes%evap(i,j)*T(i,1) else fluxes%heat_content_cond(i,j) = 0.0 endif @@ -783,14 +788,14 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Liquid runoff enters ocean at SST if land model does not provide runoff heat content. if (.not. useRiverHeatContent) then if (associated(fluxes%lrunoff) .and. associated(fluxes%heat_content_lrunoff)) then - fluxes%heat_content_lrunoff(i,j) = RZ_T_to_W_m2_degC*fluxes%lrunoff(i,j)*T(i,1) + fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*fluxes%lrunoff(i,j)*T(i,1) endif endif ! Icebergs enter ocean at SST if land model does not provide calving heat content. if (.not. useCalvingHeatContent) then if (associated(fluxes%frunoff) .and. associated(fluxes%heat_content_frunoff)) then - fluxes%heat_content_frunoff(i,j) = RZ_T_to_W_m2_degC*fluxes%frunoff(i,j)*T(i,1) + fluxes%heat_content_frunoff(i,j) = fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) endif endif @@ -1071,19 +1076,26 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%frunoff)) & call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_lrunoff)) & - call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff",G%HI,haloshift=hshift) + call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff", G%HI, & + haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_frunoff)) & - call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff",G%HI,haloshift=hshift) + call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & + haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_lprec)) & - call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec",G%HI,haloshift=hshift) + call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & + haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_fprec)) & - call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec",G%HI,haloshift=hshift) + call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec", G%HI, & + haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_icemelt)) & - call hchksum(fluxes%heat_content_icemelt, mesg//" fluxes%heat_content_icemelt",G%HI,haloshift=hshift) + call hchksum(fluxes%heat_content_icemelt, mesg//" fluxes%heat_content_icemelt", G%HI, & + haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_cond)) & - call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond",G%HI,haloshift=hshift) + call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond", G%HI, & + haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_massout)) & - call hchksum(fluxes%heat_content_massout, mesg//" fluxes%heat_content_massout",G%HI,haloshift=hshift) + call hchksum(fluxes%heat_content_massout, mesg//" fluxes%heat_content_massout", G%HI, & + haloshift=hshift, scale=RZ_T_conversion) end subroutine MOM_forcing_chksum !> Write out chksums for the driving mechanical forces. @@ -1438,58 +1450,62 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, !=============================================================== ! surface heat flux maps - handles%id_heat_content_frunoff = register_diag_field('ocean_model', 'heat_content_frunoff', & - diag%axesT1, Time, 'Heat content (relative to 0C) of solid runoff into ocean', 'W m-2', & + handles%id_heat_content_frunoff = register_diag_field('ocean_model', 'heat_content_frunoff', & + diag%axesT1, Time, 'Heat content (relative to 0C) of solid runoff into ocean', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='temperature_flux_due_to_solid_runoff_expressed_as_heat_flux_into_sea_water') - handles%id_heat_content_lrunoff = register_diag_field('ocean_model', 'heat_content_lrunoff', & - diag%axesT1, Time, 'Heat content (relative to 0C) of liquid runoff into ocean', 'W m-2', & + handles%id_heat_content_lrunoff = register_diag_field('ocean_model', 'heat_content_lrunoff', & + diag%axesT1, Time, 'Heat content (relative to 0C) of liquid runoff into ocean', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') handles%id_hfrunoffds = register_diag_field('ocean_model', 'hfrunoffds', & - diag%axesT1, Time, 'Heat content (relative to 0C) of liquid+solid runoff into ocean', 'W m-2',& + diag%axesT1, Time, 'Heat content (relative to 0C) of liquid+solid runoff into ocean', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') handles%id_heat_content_lprec = register_diag_field('ocean_model', 'heat_content_lprec', & diag%axesT1,Time,'Heat content (relative to 0degC) of liquid precip entering ocean', & - 'W m-2') + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_heat_content_fprec = register_diag_field('ocean_model', 'heat_content_fprec',& diag%axesT1,Time,'Heat content (relative to 0degC) of frozen prec entering ocean',& - 'W m-2') + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_heat_content_icemelt = register_diag_field('ocean_model', 'heat_content_icemelt',& diag%axesT1,Time,'Heat content (relative to 0degC) of water flux due to sea ice melting/freezing',& - 'W m-2') + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_heat_content_vprec = register_diag_field('ocean_model', 'heat_content_vprec', & diag%axesT1,Time,'Heat content (relative to 0degC) of virtual precip entering ocean',& - 'W m-2') + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_heat_content_cond = register_diag_field('ocean_model', 'heat_content_cond', & diag%axesT1,Time,'Heat content (relative to 0degC) of water condensing into ocean',& - 'W m-2') + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_hfrainds = register_diag_field('ocean_model', 'hfrainds', & diag%axesT1,Time,'Heat content (relative to 0degC) of liquid+frozen precip entering ocean', & - 'W m-2',standard_name='temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water',& + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + standard_name='temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water',& cmor_long_name='Heat Content (relative to 0degC) of Liquid + Frozen Precipitation') handles%id_heat_content_surfwater = register_diag_field('ocean_model', 'heat_content_surfwater',& diag%axesT1, Time, & 'Heat content (relative to 0degC) of net water crossing ocean surface (frozen+liquid)', & - 'W m-2') + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_heat_content_massout = register_diag_field('ocean_model', 'heat_content_massout', & diag%axesT1, Time,'Heat content (relative to 0degC) of net mass leaving ocean ocean via evap and ice form',& - 'W m-2', & + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & cmor_field_name='hfevapds', & cmor_standard_name='temperature_flux_due_to_evaporation_expressed_as_heat_flux_out_of_sea_water', & cmor_long_name='Heat Content (relative to 0degC) of Water Leaving Ocean via Evaporation and Ice Formation') handles%id_heat_content_massin = register_diag_field('ocean_model', 'heat_content_massin', & diag%axesT1, Time,'Heat content (relative to 0degC) of net mass entering ocean ocean',& - 'W m-2') + 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_net_heat_coupler = register_diag_field('ocean_model', 'net_heat_coupler', & diag%axesT1,Time,'Surface ocean heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& @@ -2414,63 +2430,63 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & call post_data(handles%id_heat_content_lrunoff, fluxes%heat_content_lrunoff, diag) if ((handles%id_total_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) then - total_transport = global_area_integral(fluxes%heat_content_lrunoff,G) + total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_lrunoff, total_transport, diag) endif if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then - total_transport = global_area_integral(fluxes%heat_content_frunoff,G) + total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) endif if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & call post_data(handles%id_heat_content_lprec, fluxes%heat_content_lprec, diag) if ((handles%id_total_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) then - total_transport = global_area_integral(fluxes%heat_content_lprec,G) + total_transport = global_area_integral(fluxes%heat_content_lprec, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_lprec, total_transport, diag) endif if ((handles%id_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) & call post_data(handles%id_heat_content_fprec, fluxes%heat_content_fprec, diag) if ((handles%id_total_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) then - total_transport = global_area_integral(fluxes%heat_content_fprec,G) + total_transport = global_area_integral(fluxes%heat_content_fprec, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_fprec, total_transport, diag) endif if ((handles%id_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) & call post_data(handles%id_heat_content_icemelt, fluxes%heat_content_icemelt, diag) if ((handles%id_total_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) then - total_transport = global_area_integral(fluxes%heat_content_icemelt,G) + total_transport = global_area_integral(fluxes%heat_content_icemelt, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_icemelt, total_transport, diag) endif if ((handles%id_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) & call post_data(handles%id_heat_content_vprec, fluxes%heat_content_vprec, diag) if ((handles%id_total_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) then - total_transport = global_area_integral(fluxes%heat_content_vprec,G) + total_transport = global_area_integral(fluxes%heat_content_vprec, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_vprec, total_transport, diag) endif if ((handles%id_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) & call post_data(handles%id_heat_content_cond, fluxes%heat_content_cond, diag) if ((handles%id_total_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) then - total_transport = global_area_integral(fluxes%heat_content_cond,G) + total_transport = global_area_integral(fluxes%heat_content_cond, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_cond, total_transport, diag) endif if ((handles%id_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) & call post_data(handles%id_heat_content_massout, fluxes%heat_content_massout, diag) if ((handles%id_total_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) then - total_transport = global_area_integral(fluxes%heat_content_massout,G) + total_transport = global_area_integral(fluxes%heat_content_massout,G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_massout, total_transport, diag) endif if ((handles%id_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) & call post_data(handles%id_heat_content_massin, fluxes%heat_content_massin, diag) if ((handles%id_total_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) then - total_transport = global_area_integral(fluxes%heat_content_massin,G) + total_transport = global_area_integral(fluxes%heat_content_massin, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_massin, total_transport, diag) endif @@ -2508,25 +2524,33 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) !if (associated(sfc_state%TempXpme)) then ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt !else - if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) - if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if (associated(fluxes%heat_content_icemelt)) res(i,j) = res(i,j) + fluxes%heat_content_icemelt(i,j) - if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) - if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) - if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) + if (associated(fluxes%heat_content_lrunoff)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lprec)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_icemelt)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_icemelt(i,j) + if (associated(fluxes%heat_content_vprec)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_massout)) & + res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_massout(i,j) !endif - if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) + if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) enddo ; enddo if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) if (handles%id_total_net_heat_surface > 0) then - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G) call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif if (handles%id_net_heat_surface_ga > 0) then - ave_flux = global_area_mean(res,G) + ave_flux = global_area_mean(res, G) call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) endif endif @@ -2549,7 +2573,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) enddo ; enddo if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) if (handles%id_total_heat_content_surfwater > 0) then - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G, scale=RZ_T_conversion) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) endif endif diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 22d03e9086..774a636daa 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -105,7 +105,7 @@ module MOM_variables real, dimension(:,:), pointer :: TempxPmE => NULL() !< The net inflow of water into the ocean times the !! temperature at which this inflow occurs since the - !! last call to calculate_surface_state [degC kg m-2]. + !! last call to calculate_surface_state [degC R Z ~> degC kg m-2]. !! This should be prescribed in the forcing fields, but !! as it often is not, this is a useful heat budget diagnostic. real, dimension(:,:), pointer :: internal_heat => NULL() @@ -467,7 +467,7 @@ subroutine MOM_thermovar_chksum(mesg, tv, G) if (associated(tv%salt_deficit)) & call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI) if (associated(tv%TempxPmE)) & - call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI) + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=G%US%R_to_kg_m3*G%US%Z_to_m) end subroutine MOM_thermovar_chksum end module MOM_variables diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index a97f16ee36..7e5adbb1d3 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1796,7 +1796,7 @@ subroutine register_surface_diags(Time, G, IDs, diag, tv) 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') + 'Heat flux into ocean from mass flux into ocean', 'W m-2', conversion=G%US%R_to_kg_m3*G%US%Z_to_m) 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') diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 9d80f36b93..f99b6d7f7c 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1012,7 +1012,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! smg: new code ! include heat content from water transport across ocean surface ! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie -! heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j) * & +! heat_in(i,j) = heat_in(i,j) + dt_in_T*RZL2_to_kg*G%areaT(i,j) * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) & ! + (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) & ! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & @@ -1022,7 +1022,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! smg: old code if (associated(tv%TempxPmE)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (C_p * US%L_to_m**2*G%areaT(i,j)) * tv%TempxPmE(i,j) + heat_in(i,j) = heat_in(i,j) + (C_p * RZL2_to_kg*G%areaT(i,j)) * tv%TempxPmE(i,j) enddo ; enddo elseif (associated(fluxes%evap)) then do j=js,je ; do i=is,ie diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index d525cf477f..e09c46c616 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -1118,11 +1118,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & dRcv_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 - if (associated(fluxes%heat_content_massin)) & - fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + US%s_to_T * & - T_precip * netMassIn(i) * GV%H_to_kg_m2 * fluxes%C_p * Idt + if (associated(fluxes%heat_content_massin)) & + fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & + T_precip * netMassIn(i) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & - T_precip * netMassIn(i) * GV%H_to_kg_m2 + T_precip * netMassIn(i) * GV%H_to_RZ endif ; enddo ! Now do netMassOut case in this block. @@ -1168,14 +1168,14 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & d_eb(i,k) = d_eb(i,k) - h_evap ! smg: when resolve the A=B code, we will set - ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_kg_m2*fluxes%C_p*Idt + ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*fluxes%C_p*Idt ! by uncommenting the lines here. ! we will also then completely remove TempXpme from the model. if (associated(fluxes%heat_content_massout)) & - fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) - US%s_to_T * & - T(i,k)*h_evap*GV%H_to_kg_m2 * fluxes%C_p * Idt + fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) - & + T(i,k)*h_evap*GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & - T(i,k)*h_evap*GV%H_to_kg_m2 + T(i,k)*h_evap*GV%H_to_RZ endif diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3ace76c705..22a8f51ee2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -882,8 +882,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! Local variables integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) - real :: H_limit_fluxes, IforcingDepthScale - real :: Idt + real :: H_limit_fluxes + real :: IforcingDepthScale + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: dThickness, dTemp, dSalt real :: fractionOfForcing, hOld, Ithickness real :: RivermixConst ! A constant used in implementing river mixing [Pa s]. @@ -942,7 +943,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, if (.not.associated(fluxes%sw)) return #define _OLD_ALG_ - Idt = 1.0/ (US%T_to_s*dt_in_T) + Idt = 1.0 / dt_in_T calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) @@ -1112,12 +1113,12 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! Diagnostics of heat content associated with mass fluxes if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & - T2d(i,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & - T2d(i,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & - T2d(i,k) * dThickness * GV%H_to_kg_m2 + T2d(i,k) * dThickness * GV%H_to_RZ ! Determine the energetics of river mixing before updating the state. if (calculate_energetics .and. associated(fluxes%lrunoff) .and. CS%do_rivermix) then @@ -1193,14 +1194,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, dTemp = dTemp + dThickness*T2d(i,k) ! Diagnostics of heat content associated with mass fluxes - if (associated(fluxes%heat_content_massin)) & - fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & - T2d(i,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt - if (associated(fluxes%heat_content_massout)) & + if (associated(fluxes%heat_content_massin)) & + fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt + if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & - T2d(i,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & - T2d(i,k) * dThickness * GV%H_to_kg_m2 + T2d(i,k) * dThickness * GV%H_to_RZ ! Update state by the appropriate increment. hOld = h2d(i,k) ! Keep original thickness in hand @@ -1304,7 +1305,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! convergence of SW into a layer do k=1,nz ; do i=is,ie - CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * Idt * tv%C_p * GV%H_to_kg_m2 + CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * US%s_to_T*Idt * tv%C_p * GV%H_to_kg_m2 enddo ; enddo ! Perform a cumulative sum upwards from bottom to From b4f52640527cf12945015567f3508fe3d58974e9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 8 Oct 2019 13:58:18 -0400 Subject: [PATCH 172/259] ALE: Float ID inequality replaced with integer A diagnostic ID was compared to floating point 0. to test if it had been set. This patch replaces this with an integer inequality test. This resolves GitHub Issue #1016. Thanks to Stephen Griffies for reporting. --- src/ALE/MOM_ALE.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 8eed4aa925..898861c914 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -799,12 +799,12 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Intermediate steps for tendency of tracer concentration and tracer content. if (present(dt)) then - if (Tr%id_remap_conc>0) 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 + 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 + if (Tr%id_remap_cont > 0 .or. Tr%id_remap_cont_2d > 0) then do k=1,GV%ke work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt enddo From 5312d996add0a04460b0686fe376986cc4c205ed Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 15:34:58 -0400 Subject: [PATCH 173/259] Cleaned up code in insert_brine Cleaned up code in insert_brine. However, this routine does not appear to be in use, and it does not appear to have ever been properly coded and tested. I think that this routine is a candidate for deletion, and the flag that triggers its use, ALT_REJECT_BELOW_ML, should be obsoleted. All answers are bitwise identical with these changes. --- .../vertical/MOM_diabatic_aux.F90 | 53 ++++++++++--------- 1 file changed, 27 insertions(+), 26 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 22a8f51ee2..de43a0b946 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -399,28 +399,31 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_la !! which layer receivees the brine. ! local variables - real :: salt(SZI_(G)) ! The amount of salt rejected from - ! sea ice. [grams] - real :: dzbr(SZI_(G)) ! cumulative depth over which brine is distributed + real :: salt(SZI_(G)) ! The amount of salt rejected from sea ice [ppt R Z ~> gramSalt m-2] + real :: dzbr(SZI_(G)) ! Cumulative depth over which brine is distributed [H ~> m to kg m-2] real :: inject_layer(SZI_(G),SZJ_(G)) ! diagnostic real :: p_ref_cv(SZI_(G)) real :: T(SZI_(G),SZK_(G)) real :: S(SZI_(G),SZK_(G)) - real :: h_2d(SZI_(G),SZK_(G)) + real :: h_2d(SZI_(G),SZK_(G)) ! A 2-d slice of h with a minimum thickness [H ~> m to kg m-2] real :: Rcv(SZI_(G),SZK_(G)) - real :: mc ! A layer's mass [kg m-2]. real :: s_new,R_new,t0,scale, cdz integer :: i, j, k, is, ie, js, je, nz, ks - real, parameter :: brine_dz = 1.0 ! minumum thickness over which to distribute brine + real :: brine_dz ! minumum thickness over which to distribute brine [H ~> m or kg m-2] real, parameter :: s_max = 45.0 ! salinity bound is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(fluxes%salt_flux)) return + !### Injecting the brine into a single layer with a prescribed thickness seems problematic, + ! because it is not convergent when resolution becomes very fine. I think that this whole + ! subroutine needs to be revisited.- RWH + p_ref_cv(:) = tv%P_ref + brine_dz = 1.0*GV%m_to_H inject_layer(:,:) = nz @@ -429,14 +432,14 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_la salt(:)=0.0 ; dzbr(:)=0.0 do i=is,ie ; if (G%mask2dT(i,j) > 0.) then - salt(i) = dt_in_T * (1000. * US%R_to_kg_m3*US%Z_to_m*fluxes%salt_flux(i,j)) + salt(i) = dt_in_T * (1000. * fluxes%salt_flux(i,j)) endif ; enddo do k=1,nz do i=is,ie - T(i,k)=tv%T(i,j,k); S(i,k)=tv%S(i,j,k) + T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) ! avoid very small thickness - h_2d(i,k)=MAX(h(i,j,k), GV%Angstrom_H) + h_2d(i,k) = MAX(h(i,j,k), GV%Angstrom_H) enddo call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & @@ -449,12 +452,11 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_la do k=nkmb+1,nz-1 ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - mc = GV%H_to_kg_m2 * h_2d(i,k) - s_new = S(i,k) + salt(i)/mc + s_new = S(i,k) + salt(i) / (GV%H_to_RZ * h_2d(i,k)) t0 = T(i,k) - call calculate_density(t0,s_new,tv%P_Ref,R_new,tv%eqn_of_state) + call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state) if (R_new < 0.5*(Rcv(i,k)+Rcv(i,k+1)) .and. s_new 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - mc = GV%H_to_kg_m2 * h_2d(i,k) - dzbr(i)=dzbr(i)+h_2d(i,k) - inject_layer(i,j) = min(inject_layer(i,j),real(k)) + dzbr(i) = dzbr(i) + h_2d(i,k) + inject_layer(i,j) = min(inject_layer(i,j), real(k)) endif enddo ; enddo @@ -473,9 +474,8 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_la do k=1,GV%nkml ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then - mc = GV%H_to_kg_m2 * h_2d(i,k) - dzbr(i)=dzbr(i)+h_2d(i,k) - inject_layer(i,j) = min(inject_layer(i,j),real(k)) + dzbr(i) = dzbr(i) + h_2d(i,k) + inject_layer(i,j) = min(inject_layer(i,j), real(k)) endif enddo ; enddo @@ -483,14 +483,15 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_la do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. salt(i) > 0.) then ! if (dzbr(i)< brine_dz) call MOM_error(FATAL,"insert_brine: failed") - ks=inject_layer(i,j) - cdz=0.0 + ks = inject_layer(i,j) + cdz = 0.0 do k=ks,nz - mc = GV%H_to_kg_m2 * h_2d(i,k) - scale = h_2d(i,k)/dzbr(i) - cdz=cdz+h_2d(i,k) - if (cdz > 1.0) exit - tv%S(i,j,k) = tv%S(i,j,k) + scale*salt(i)/mc + scale = h_2d(i,k) / dzbr(i) + cdz = cdz + h_2d(i,k) + !### I think that the logic of this line is wrong. Moving it down a line + ! would seem to make more sense. - RWH + if (cdz > brine_dz) exit + tv%S(i,j,k) = tv%S(i,j,k) + scale*salt(i) / (GV%H_to_RZ * h_2d(i,k)) enddo endif enddo From e55ad234ccfce189bd7ff071f4f32b541852b468 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 16:30:55 -0400 Subject: [PATCH 174/259] +Pass timestep to step_forward_MEKE in units of [T] Pass timestep to step_forward_MEKE and calc_slope_functions in units of [T]. All answers are bitwise identical, but the units of arguments to two public subroutines have rescaled dimensions. --- src/core/MOM.F90 | 10 +++++----- src/parameterizations/lateral/MOM_MEKE.F90 | 13 +++++-------- .../lateral/MOM_lateral_mixing_coeffs.F90 | 8 ++++---- 3 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 612862a616..afa2a8c748 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -922,7 +922,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call enable_averaging(dt_thermo, Time_local+real_to_time(dt_thermo-dt), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, US%s_to_T*dt, G, GV, US, CS%VarMix) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, US%s_to_T*dt_thermo, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) @@ -995,7 +995,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, US%s_to_T*dt, G, GV, US, CS%VarMix) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, US%s_to_T*dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) @@ -1029,7 +1029,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) + CS%visc, US%s_to_T*dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) call disable_averaging(CS%diag) ! Advance the dynamics time by dt. @@ -1403,7 +1403,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, US%s_to_T*REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1428,7 +1428,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, US%s_to_T*REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index cd63937530..2b509a0a72 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -97,7 +97,7 @@ module MOM_MEKE !> Integrates forward-in-time the MEKE eddy energy equation. !! See \ref section_MEKE_equations. -subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, hv) +subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt_in_T, G, GV, US, 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. @@ -106,7 +106,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. - real, intent(in) :: dt !< Model(baroclinic) time-step [s]. + real, intent(in) :: dt_in_T !< Model(baroclinic) time-step [T ~> s]. type(MEKE_CS), pointer :: CS !< MEKE control structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: hu !< Accumlated zonal mass flux [H L2 ~> m3 or kg]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: hv !< Accumlated meridional mass flux [H L2 ~> m3 or kg] @@ -117,9 +117,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h I_mass, & ! The inverse of mass [R-1 Z-1 ~> m2 kg-1]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. - ! MEKE_GM_src, & ! The MEKE source from thickness mixing [m2 s-3]. - ! MEKE_mom_src, & ! The MEKE source from momentum [m2 s-3]. - ! MEKE_GME_snk, & ! The MEKE sink from GME backscatter [m2 s-3]. drag_rate_visc, & ! Near-bottom velocity contribution to bottom dratg [L T-1 ~> m s-1] drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. drag_rate_J15, & ! The MEKE spindown timescale due to bottom drag with the Jansen 2015 scheme. @@ -193,7 +190,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m) endif - sdt = US%s_to_T*dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping + sdt = dt_in_T*CS%MEKE_dtScale ! Scaled dt to use for time-stepping Rho0 = GV%Rho0 mass_neglect = GV%H_to_RZ * GV%H_subroundoff cdrag2 = CS%cdrag**2 @@ -459,8 +456,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo if (CS%MEKE_advection_factor>0.) then !### I think that for dimensional consistency, this should be: - ! advFac = GV%H_to_RZ * CS%MEKE_advection_factor / (US%s_to_T*dt) - advFac = US%kg_m3_to_R*GV%H_to_Z * CS%MEKE_advection_factor / (US%s_to_T*dt) + ! advFac = GV%H_to_RZ * CS%MEKE_advection_factor / sdt + advFac = US%kg_m3_to_R*GV%H_to_Z * CS%MEKE_advection_factor / dt_in_T !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ! Here the units of the quantities added to MEKE_uflux and MEKE_vflux are [m L4 T-3]. diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index c3c88b4795..46036175c7 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -395,19 +395,19 @@ end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity -subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) +subroutine calc_slope_functions(h, tv, dt_in_T, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, intent(in) :: dt !< Time increment [s] + real, intent(in) :: dt_in_T !< Time increment [T ~> s] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [T-2 ~> s-2] - real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [s-2] + real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [T-2 ~> s-2] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") @@ -415,7 +415,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) if (CS%calculate_Eady_growth_rate) then call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then - call calc_isoneutral_slopes(G, GV, US, h, e, tv, US%s_to_T*dt*CS%kappa_smooth, & + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_in_T*CS%kappa_smooth, & CS%slope_x, CS%slope_y, N2_u, N2_v, 1) call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) From 55a048425695652046c0f4274dc098b655bc1f8f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 16:31:19 -0400 Subject: [PATCH 175/259] Fixed a rescaling factor in entrainment_diffusive Corrected a dimensional rescaling factor in entrainment_diffusive, which would only impact buoyancy forced cases without temperature and salinity as state variables. All answers in the MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_entrain_diffusive.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 3942b66f22..6f1b728a0d 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -382,7 +382,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & htot(i) = h(i,j,1) - Angstrom enddo if (associated(fluxes%buoy)) then ; do i=is,ie - maxF(i,1) = (dt*fluxes%buoy(i,j)) / (GV%g_prime(2)*US%m_to_Z) + maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) enddo ; endif endif From 59b18f0ae65584a7f5a827dedb56b3fa3785a87d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 17:30:44 -0400 Subject: [PATCH 176/259] +Pass timestep to btstep in units of [T] Pass timestep to btstep in units of [T], and changed the internal units of CS%dtbt and CS%dtbt_max to [T] in barotropic_CS. All answers are bitwise identical, but the units of an arguments to a public subroutine has rescaled dimensions. --- src/core/MOM_barotropic.F90 | 43 +++++++++++++++-------------- src/core/MOM_dynamics_split_RK2.F90 | 6 ++-- 2 files changed, 25 insertions(+), 24 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index fbadddd4d4..bdb46a4e5f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -159,10 +159,10 @@ module MOM_barotropic type(BT_OBC_type) :: BT_OBC !< A structure with all of this modules fields !! for applying open boundary conditions. - real :: dtbt !< The barotropic time step [s]. + real :: dtbt !< The barotropic time step [T ~> s]. real :: dtbt_fraction !< The fraction of the maximum time-step that !! should used. The default is 0.98. - real :: dtbt_max !< The maximum stable barotropic time step [s]. + real :: dtbt_max !< The maximum stable barotropic time step [T ~> s]. real :: dt_bt_filter !< The time-scale over which the barotropic mode solutions are !! filtered [T ~> s] if positive, or as a fraction of DT if !! negative [nondim]. This can never be taken to be longer than 2*dt. @@ -380,7 +380,7 @@ module MOM_barotropic !! 0.0 and 1.0 determining the scheme. In practice, bebt must be of !! order 0.2 or greater. A forwards-backwards treatment of the !! Coriolis terms is always used. -subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & +subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, pbce, & eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & eta_out, uhbtav, vhbtav, G, GV, US, CS, & visc_rem_u, visc_rem_v, etaav, OBC, BT_cont, eta_PF_start, & @@ -394,8 +394,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !! velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_in !< The initial barotropic free surface height !! anomaly or column mass anomaly [H ~> m or kg m-2]. - real, intent(in) :: dt !< The time increment to integrate over. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations [m s-2]. + real, intent(in) :: dt_in_T !< The time increment to integrate over [T ~> s]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations, + !! [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations, !! [L T-2 ~> m s-2]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces @@ -584,7 +585,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: dtbt ! The barotropic time step [T ~> s]. - real :: dt_in_T ! The baroclinic time step [T ~> s]. real :: bebt ! A copy of CS%bebt [nondim]. real :: be_proj ! The fractional amount by which velocities are projected ! when project_velocity is true. For now be_proj is set @@ -651,7 +651,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed 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 - dt_in_T = US%s_to_T*dt + Idt = 1.0 / dt_in_T accel_underflow = CS%vel_underflow * Idt @@ -709,10 +709,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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) + nstep = CEILING(dt_in_T/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, & - & " seconds, max ", ES12.6, ".")') (dt/nstep), CS%dtbt_max + & " seconds, max ", ES12.6, ".")') (US%T_to_s*dt_in_T/nstep), US%T_to_s*CS%dtbt_max call MOM_mesg(mesg, 3) endif CS%nstep_last = nstep @@ -738,7 +738,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) then do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) if (do_hifreq_output) & - time_bt_start = time_end_in - real_to_time(dt) + time_bt_start = time_end_in - real_to_time(US%T_to_s*dt_in_T) endif !--- begin setup for group halo update @@ -2367,8 +2367,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) call min_across_PEs(dtbt_max) if (id_clock_sync > 0) call cpu_clock_end(id_clock_sync) - CS%dtbt = CS%dtbt_fraction * US%T_to_s * dtbt_max - CS%dtbt_max = US%T_to_s * dtbt_max + CS%dtbt = CS%dtbt_fraction * dtbt_max + CS%dtbt_max = dtbt_max end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. @@ -3658,8 +3658,6 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) ! the sum of the layer thicknesses [H ~> m or kg m-2]. real :: d_eta ! The difference between estimates of the total ! thicknesses [H ~> m or kg m-2]. - real :: limit_dt ! The fractional mass-source limit divided by the - ! thermodynamic time step [s-1]. integer :: is, ie, js, je, nz, i, j, k real, parameter :: frac_cor = 0.25 real, parameter :: slow_rate = 0.125 @@ -3670,7 +3668,7 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - !$OMP parallel do default(shared) private(eta_h,h_tot,limit_dt,d_eta) + !$OMP parallel do default(shared) private(eta_h,h_tot,d_eta) do j=js,je do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo if (GV%Boussinesq) then @@ -3741,7 +3739,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, real :: gtot_estimate ! Summed GV%g_prime [L2 Z-1 T-2 ~> m s-2], to give an upper-bound estimate for pbce. real :: SSH_extra ! An estimate of how much higher SSH might get, for use ! in calculating the safe external wave speed [Z ~> m]. - real :: dtbt_input, dtbt_tmp + real :: dtbt_input ! The input value of DTBT, [nondim] if negative or [s] if positive. + real :: dtbt_tmp ! A temporary copy of CS%dtbt read from a restart file [T ~> s] real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag ! piston velocities. character(len=200) :: inputdir ! The directory in which to find input files. @@ -4159,7 +4158,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) CS%dtbt_fraction = -dtbt_input dtbt_tmp = -1.0 - if (query_initialized(CS%dtbt, "DTBT", restart_CS)) dtbt_tmp = CS%dtbt + if (query_initialized(CS%dtbt, "DTBT", restart_CS)) then + dtbt_tmp = CS%dtbt + if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & + dtbt_tmp = (US%s_to_T / US%s_to_T_restart) * CS%dtbt + endif ! Estimate the maximum stable barotropic time step. gtot_estimate = 0.0 @@ -4167,14 +4170,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra) if (dtbt_input > 0.0) then - CS%dtbt = dtbt_input + CS%dtbt = US%s_to_T * dtbt_input elseif (dtbt_tmp > 0.0) then CS%dtbt = dtbt_tmp endif if ((dtbt_tmp > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. - call log_param(param_file, mdl, "DTBT as used", CS%dtbt) - call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max) + call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s) + call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s) ! ubtav, vbtav, ubt_IC, vbt_IC, uhbt_IC, and vhbt_IC are allocated and ! initialized in register_barotropic_restarts. diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 3a6e166395..e2cdfd22c7 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -320,7 +320,6 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & real :: dt_in_T ! The dynamics time step [T ~> s] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. - real :: Idt ! The inverse of the timestep [s-1] logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating @@ -335,7 +334,6 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta dt_in_T = US%s_to_T*dt - Idt = 1.0 / dt sym=.false.;if (G%Domain%symmetric) sym=.true. ! switch to include symmetric domain in checksums @@ -534,7 +532,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (calc_dtbt) call set_dtbt(G, GV, US, CS%barotropic_CSp, eta, CS%pbce) if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the predictor step call to btstep. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & + call btstep(u, v, eta, dt_in_T, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, & G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & OBC=CS%OBC, BT_cont=CS%BT_cont, eta_PF_start=eta_PF_start, & @@ -734,7 +732,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the corrector step call to btstep. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, & + call btstep(u, v, eta, dt_in_T, u_bc_accel, v_bc_accel, forces, CS%pbce, & CS%eta_PF, u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, & eta_pred, CS%uhbt, CS%vhbt, G, GV, US, CS%barotropic_CSp, & CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, OBC=CS%OBC, & From f1b9c66a47ba91864603683b6e50e7344c5a480c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 17:54:47 -0400 Subject: [PATCH 177/259] +Pass timestep to btstep in units of [T] Pass timestep to btstep in units of [T], and changed the internal units of CS%dtbt and CS%dtbt_max to [T] in barotropic_CS. All answers are bitwise identical, but the units of an arguments to a public subroutine has rescaled dimensions. --- src/core/MOM.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index afa2a8c748..226fde6810 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -896,10 +896,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! various unit conversion factors type(MOM_diag_IDs), pointer :: IDs => NULL() ! A structure with the diagnostic IDs. real, dimension(:,:,:), pointer :: & - u => NULL(), & ! u : zonal velocity component [m s-1] - v => NULL(), & ! v : meridional velocity component [m s-1] + u => NULL(), & ! u : zonal velocity component [L T-1 ~> m s-1] + v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1] h => NULL() ! h : layer thickness [H ~> m or kg m-2] + real :: dt_in_T ! The time step covered by this call [T ~> s] logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. logical :: showCallTree @@ -916,13 +917,14 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & showCallTree = callTree_showQuery() call cpu_clock_begin(id_clock_dynamics) + dt_in_T = US%s_to_T*dt if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then call enable_averaging(dt_thermo, Time_local+real_to_time(dt_thermo-dt), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, US%s_to_T*dt, G, GV, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt_in_T, G, GV, US, CS%VarMix) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, US%s_to_T*dt_thermo, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) @@ -995,8 +997,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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, US%s_to_T*dt, G, GV, US, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, US%s_to_T*dt, G, GV, US, & + call calc_slope_functions(h, CS%tv, dt_in_T, G, GV, US, CS%VarMix) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_in_T, G, GV, US, & 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) @@ -1013,7 +1015,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) - call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, US%s_to_T*dt, CS%visc%MLD, & + call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt_in_T, CS%visc%MLD, & CS%VarMix, G, GV, US, 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)) @@ -1029,7 +1031,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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, US%s_to_T*dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) + CS%visc, dt_in_T, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) call disable_averaging(CS%diag) ! Advance the dynamics time by dt. @@ -2703,8 +2705,6 @@ subroutine extract_surface_state(CS, sfc_state) type(verticalGrid_type), pointer :: GV => NULL() !< structure containing vertical grid info type(unit_scale_type), pointer :: US => NULL() !< structure containing various unit conversion factors real, dimension(:,:,:), pointer :: & -! u => NULL(), & !< u : zonal velocity component [m s-1] -! v => NULL(), & !< v : meridional velocity component [m s-1] h => NULL() !< h : layer thickness [H ~> m or kg m-2] real :: depth(SZI_(CS%G)) !< Distance from the surface in depth units [Z ~> m] real :: depth_ml !< Depth over which to average to determine mixed From 8ade6dea45534046d92bcc6c8e77a6590c8edd6f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 18:38:47 -0400 Subject: [PATCH 178/259] +Pass MLDdensityDifference in units of [R] Pass MLDdensityDifference to diagnoseMLDbyDensityDifference in units of [R]. All answers are bitwise identical. --- .../vertical/MOM_diabatic_aux.F90 | 27 ++++++++++--------- .../vertical/MOM_diabatic_driver.F90 | 17 ++++++------ 2 files changed, 23 insertions(+), 21 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index de43a0b946..d8c7517542 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -558,15 +558,15 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity [m s-1] + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity [m s-1] + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: u_h !< Zonal velocity interpolated to h points [m s-1]. + intent(out) :: u_h !< Zonal velocity interpolated to h points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: v_h !< Meridional velocity interpolated to h points [m s-1]. + intent(out) :: v_h !< Meridional velocity interpolated to h points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: ea !< The amount of fluid entrained from the layer !! above within this time step [H ~> m or kg m-2]. @@ -722,7 +722,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any !! available thermodynamic fields. - real, intent(in) :: densityDiff !< Density difference to determine MLD [kg m-3] + real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD @@ -873,10 +873,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, !! forcing through each layer [R Z3 T-2 ~> J m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: dSV_dT !< Partial derivative of specific volume with - !! potential temperature [R-1 degC-1]. + !! potential temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: dSV_dS !< Partial derivative of specific volume with - !! salinity [R-1 ppt-1]. + !! salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. @@ -888,7 +888,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: dThickness, dTemp, dSalt real :: fractionOfForcing, hOld, Ithickness - real :: RivermixConst ! A constant used in implementing river mixing [Pa s]. + real :: RivermixConst ! A constant used in implementing river mixing [R Z2 T-1 ~> Pa s]. + real, dimension(SZI_(G)) :: & d_pres, & ! pressure change across a layer [Pa] p_lay, & ! average pressure in a layer [Pa] @@ -1124,11 +1125,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! Determine the energetics of river mixing before updating the state. if (calculate_energetics .and. associated(fluxes%lrunoff) .and. CS%do_rivermix) then ! Here we add an additional source of TKE to the mixed layer where river - ! is present to simulate unresolved estuaries. The TKE input is diagnosed - ! as follows: - ! TKE_river[m3 s-3] = 0.5*rivermix_depth*g*(1/rho)*drho_ds* - ! River*(Samb - Sriver) = CS%mstar*U_star^3 - ! where River is in units of [m s-1]. + ! is present to simulate unresolved estuaries. The TKE input, TKE_river in + ! [Z3 T-3 ~> m3 s-3], is diagnosed as follows: + ! TKE_river = 0.5*rivermix_depth*g*(1/rho)*drho_ds* + ! River*(Samb - Sriver) = CS%mstar*U_star^3 + ! where River is in units of [Z T-1 ~> m s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 561192dab1..4d8025a1d9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -163,7 +163,7 @@ module MOM_diabatic_driver !< vertical diffusion of T and S logical :: debug_energy_req !< If true, test the mixing energy requirement code. type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output - real :: MLDdensityDifference !< Density difference used to determine MLD_user + real :: MLDdensityDifference !< Density difference used to determine MLD_user [R ~> kg m-3] real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the !! average stratification at the base of the mixed layer [Z ~> m]. @@ -420,11 +420,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! Diagnose mixed layer depths. call enable_averaging(dt, Time_end, CS%diag) if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, US, CS%diag, & + call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, US, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag) endif if (CS%id_MLD_user > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag) @@ -1966,10 +1966,10 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC m s-1] - Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC m s-1] - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt m s-1] - Sadv_flx ! advective diapycnal salt flux across interfaces [ppt m s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] ! The following 5 variables are only used with a bulk mixed layer. real, pointer, dimension(:,:,:) :: & @@ -3436,7 +3436,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "The density difference used to determine a diagnostic mixed "//& "layer depth, MLD_user, following the definition of Levitus 1982. "//& "The MLD is the depth at which the density is larger than the "//& - "surface density by the specified amount.", units='kg/m3', default=0.1) + "surface density by the specified amount.", & + units='kg/m3', default=0.1, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DIAG_DEPTH_SUBML_N2", CS%dz_subML_N2, & "The distance over which to calculate a diagnostic of the "//& "stratification at the base of the mixed layer.", & From 0d43bc31c13bbeea81f639522fc76fe7a0422fde Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 18:41:45 -0400 Subject: [PATCH 179/259] Corrected units in parameterization code comments Widespread cleanup of units in comments in vertical parameterizations. All answers are bitwise identical. --- .../vertical/MOM_energetic_PBL.F90 | 12 +++++----- .../vertical/MOM_internal_tide_input.F90 | 4 ++-- .../vertical/MOM_kappa_shear.F90 | 22 ++++++++--------- .../vertical/MOM_set_diffusivity.F90 | 24 +++++++++---------- .../vertical/MOM_set_viscosity.F90 | 2 +- .../vertical/MOM_vert_friction.F90 | 2 +- 6 files changed, 32 insertions(+), 34 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 0174bfaa58..8ae83ca615 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -37,7 +37,7 @@ module MOM_energetic_PBL !/ Constants real :: VonKar = 0.41 !< The von Karman coefficient. This should be runtime, but because !! it is runtime in KPP and set to 0.4 it might change answers. - real :: omega !< The Earth's rotation rate [T-1]. + real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: omega_frac !< When setting the decay scale for turbulence, use this fraction of !! the absolute rotation rate blended with the local value of f, as !! sqrt((1-of)*f^2 + of*4*omega^2) [nondim]. @@ -343,7 +343,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: absf ! The absolute value of f [T-1]. + real :: absf ! The absolute value of f [T-1 ~> s-1]. real :: U_star ! The surface friction velocity [Z T-1 ~> m s-1]. real :: U_Star_Mean ! The surface friction without gustiness [Z T-1 ~> m s-1]. real :: B_Flux ! The surface buoyancy flux [Z2 T-3 ~> m2 s-3] @@ -539,9 +539,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZK_(GV)), intent(in) :: u !< Zonal velocities interpolated to h points - !! [m s-1]. + !! [L T-1 ~> m s-1]. real, dimension(SZK_(GV)), intent(in) :: v !< Zonal velocities interpolated to h points - !! [m s-1]. + !! [L T-1 ~> m s-1]. real, dimension(SZK_(GV)), intent(in) :: T0 !< The initial layer temperatures [degC]. real, dimension(SZK_(GV)), intent(in) :: S0 !< The initial layer salinities [ppt]. @@ -740,7 +740,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! from the surface. ! The following are only used for diagnostics. - real :: dt__diag ! A copy of dt_diag (if present) or dt [T]. + real :: dt__diag ! A copy of dt_diag (if present) or dt [T ~> s]. real :: I_dtdiag ! = 1.0 / dt__diag [T-1 ~> s-1]. !---------------------------------------------------------------------- @@ -1749,7 +1749,7 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: UStar !< ustar w/ gustiness [Z T-1 ~> m s-1] real, intent(in) :: UStar_Mean !< ustar w/o gustiness [Z T-1 ~> m s-1] - real, intent(in) :: Abs_Coriolis !< abolute value of the Coriolis parameter [T-1] + real, intent(in) :: Abs_Coriolis !< abolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] real, intent(out) :: Mstar !< Ouput mstar (Mixing/ustar**3) [nondim] diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 2f4f853162..feb5c3d45c 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -64,7 +64,7 @@ module MOM_int_tide_input real, allocatable, dimension(:,:) :: & TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. - tideamp, & !< The amplitude of the tidal velocities [m s-1]. + tideamp, & !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. Nb !< The bottom stratification [T-1 ~> s-1]. end type int_tide_input_type @@ -401,7 +401,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) if (max_frac_rough >= 0.0) & itide%h2(i,j) = min((max_frac_rough*G%bathyT(i,j))**2, itide%h2(i,j)) - ! Compute the fixed part of internal tidal forcing; units are [R Z3 T-2 = J m-2] here. + ! Compute the fixed part of internal tidal forcing; units are [R Z3 T-2 ~> J m-2] here. CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor*GV%Rho0*& kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index d55ce8c9c8..d315a18b16 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -73,7 +73,7 @@ module MOM_kappa_shear !! massive layers in this calculation. ! I can think of no good reason why this should be false. - RWH real :: vel_underflow !< Velocity components smaller than vel_underflow - !! are set to 0 [Z T-1 ~> m s-1]. + !! are set to 0 [L T-1 ~> m s-1]. ! logical :: layer_stagger = .false. ! If true, do the calculations centered at ! layers, rather than the interfaces. logical :: debug = .false. !< If true, write verbose debugging messages. @@ -734,7 +734,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & local_src_avg, & ! The time-integral of the local source [nondim]. tol_min, & ! Minimum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_max, & ! Maximum tolerated ksrc for the corrector step [T-1 ~> s-1]. - tol_chg, & ! The tolerated change integrated in time [s T-nondim]. + tol_chg, & ! The tolerated change integrated in time [nondim]. dist_from_top, & ! The distance from the top surface [Z ~> m]. local_src ! The sum of all sources of kappa, including kappa_src and ! sources from the elliptic term [T-1 ~> s-1]. @@ -1210,8 +1210,8 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, & !! layers?). real, dimension(nz+1), intent(in) :: kappa !< The diapycnal diffusivity at interfaces, !! [Z2 T-1 ~> m2 s-1]. - real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity [m s-1]. - real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity [m s-1]. + real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity [L T-1 ~> m s-1]. + real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity [L T-1 ~> m s-1]. real, dimension(nz), intent(in) :: T0 !< The initial temperature [degC]. real, dimension(nz), intent(in) :: S0 !< The initial salinity [ppt]. real, dimension(nz), intent(in) :: dz !< The grid spacing of layers [Z ~> m]. @@ -1222,8 +1222,8 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, & real, dimension(nz+1), intent(in) :: dbuoy_dS !< The partial derivative of buoyancy with !! salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. real, intent(in) :: dt !< The time step [T ~> s]. - real, dimension(nz), intent(inout) :: u !< The zonal velocity after dt [m s-1]. - real, dimension(nz), intent(inout) :: v !< The meridional velocity after dt [m s-1]. + real, dimension(nz), intent(inout) :: u !< The zonal velocity after dt [L T-1 ~> m s-1]. + real, dimension(nz), intent(inout) :: v !< The meridional velocity after dt [L T-1 ~> m s-1]. real, dimension(nz), intent(inout) :: T !< The temperature after dt [degC]. real, dimension(nz), intent(inout) :: Sal !< The salinity after dt [ppt]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1237,13 +1237,13 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, & !! diffusivity. real, optional, intent(in) :: vel_underflow !< If present and true, any velocities that !! are smaller in magnitude than this value are - !! set to 0 [m s-1]. + !! set to 0 [L T-1 ~> m s-1]. ! Local variables real, dimension(nz+1) :: c1 real :: L2_to_Z2 ! A conversion factor from horizontal length units to vertical depth ! units squared [Z2 s2 T-2 m-2 ~> 1]. - real :: underflow_vel ! Velocities smaller in magnitude than underflow_vel are set to 0 [m s-1]. + real :: underflow_vel ! Velocities smaller in magnitude than underflow_vel are set to 0 [L T-1 ~> m s-1]. real :: a_a, a_b, b1, d1, bd1, b1nz_0 integer :: k, ks, ke @@ -1352,7 +1352,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real, dimension(nz+1), intent(in) :: dz_Int !< The thicknesses associated with interfaces !! [Z-1 ~> m-1]. real, dimension(nz+1), intent(in) :: I_L2_bdry !< The inverse of the squared distance to - !! boundaries [Z-2 !> m-2]. + !! boundaries [Z-2 ~> m-2]. real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers [Z-1 ~> m-1]. real, intent(in) :: f2 !< The squared Coriolis parameter [T-2 ~> s-2]. type(Kappa_shear_CS), pointer :: CS !< A pointer to this module's control structure. @@ -1366,7 +1366,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces !! [Z2 T-1 ~> m2 s-1]. real, dimension(nz+1), optional, & - intent(out) :: kappa_src !< The source term for kappa [T-1]. + intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1]. real, dimension(nz+1), optional, & intent(out) :: local_src !< The sum of all local sources for kappa, !! [T-1 ~> s-1]. @@ -1422,7 +1422,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Temporary variables used in the Newton's method iterations. real :: decay_term_k ! The decay term in the diffusivity equation real :: decay_term_Q ! The decay term in the TKE equation - proportional to [T-1 ~> s-1] - real :: I_Q ! The inverse of TKE [s2 m-2] + real :: I_Q ! The inverse of TKE [T2 Z-2 ~> s2 m-2] real :: kap_src real :: v1 ! A temporary variable proportional to [T-1 ~> s-1] real :: v2 diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index ad6fbe11a0..e358d66662 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -58,8 +58,8 @@ module MOM_set_diffusivity logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with !! GV%nk_rho_varies variable density mixed & buffer layers. real :: FluxRi_max !< The flux Richardson number where the stratification is - !! large enough that N2 > omega2. The full expression for - !! the Flux Richardson number is usually + !! large enough that N2 > omega2 [nondim]. The full expression + !! for the Flux Richardson number is usually !! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. logical :: bottomdraglaw !< If true, the bottom stress is calculated with a !! drag law c_drag*|u|*u. @@ -93,8 +93,6 @@ module MOM_set_diffusivity real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [R Z2 T-1 ~> J s m-3] real :: dissip_Kd_min !< Minimum Kd [Z2 T-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 - real :: TKE_itide_max !< maximum internal tide conversion [W m-2] - !! available to mix above the BBL real :: omega !< Earth's rotation frequency [T-1 ~> s-1] logical :: ML_radiation !< allow a fraction of TKE available from wind work !! to penetrate below mixed layer base with a vertical @@ -107,7 +105,7 @@ module MOM_set_diffusivity !! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is !! calculated the same way as in the mixed layer code. !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), - !! where N2 is the squared buoyancy frequency [s-2] and OMEGA2 + !! where N2 is the squared buoyancy frequency [T-2 ~> s-2] and OMEGA2 !! is the rotation rate of the earth squared. real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence !! radiated from the base of the mixed layer [Z2 T-1 ~> m2 s-1]. @@ -224,7 +222,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, !! properties of the ocean. type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properies, and related fields. - real, intent(in) :: dt_in_T !< Time increment [s]. + real, intent(in) :: dt_in_T !< Time increment [T ~> s]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. @@ -246,7 +244,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, real, dimension(SZI_(G),SZK_(G)) :: & N2_lay, & !< squared buoyancy frequency associated with layers [T-2 ~> s-2] - maxTKE, & !< energy required to entrain to h_max [m3 T-3] + maxTKE, & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] TKE_to_Kd !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer !< [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] @@ -674,10 +672,10 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! above or below [Z ~> m]. real :: dRho_lay ! density change across a layer [R ~> kg m-3] real :: Omega2 ! rotation rate squared [T-2 ~> s-2] - real :: G_Rho0 ! gravitation accel divided by Bouss ref density [Z T-2 R-1 -> m4 s-2 kg-1] - real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z T-2 R-1 -> m4 s-2 kg-1] + real :: G_Rho0 ! gravitation accel divided by Bouss ref density [Z T-2 R-1 ~> m4 s-2 kg-1] + real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z T-2 R-1 ~> m4 s-2 kg-1] real :: I_Rho0 ! inverse of Boussinesq reference density [R-1 ~> m3 kg-1] - real :: I_dt ! 1/dt [T-1] + real :: I_dt ! 1/dt [T-1 ~> s-1] real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] real :: hN2pO2 ! h (N^2 + Omega^2), in [m3 T-2 Z-2 ~> m s-2]. logical :: do_i(SZI_(G)) @@ -1450,9 +1448,9 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & TKE_remaining = exp(-Idecay*dh) * TKE_remaining z_bot = z_bot + h(i,j,k)*GV%H_to_Z ! Distance between upper interface of layer and the bottom [Z ~> m]. - D_minus_z = max(total_thickness - z_bot, 0.) ! Thickness above layer, Z. + D_minus_z = max(total_thickness - z_bot, 0.) ! Thickness above layer [Z ~> m]. - ! Diffusivity using law of the wall, limited by rotation, at height z [m2 s-1]. + ! Diffusivity using law of the wall, limited by rotation, at height z [Z2 T-1 ~> m2 s-1]. ! This calculation is at the upper interface of the layer if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then Kd_wall = 0. @@ -1461,7 +1459,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & / (ustar_D + absf * (z_bot * D_minus_z)) endif - ! TKE associated with Kd_wall [m3 s-2]. + ! TKE associated with Kd_wall [Z3 T-3 ~> m3 s-3]. ! This calculation if for the volume spanning the interface. TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 51884cb487..73193e4a25 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -187,7 +187,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) real :: U_bg_sq ! The square of an assumed background ! velocity, for calculating the mean ! magnitude near the bottom for use in the - ! quadratic bottom drag [m2 s-2]. + ! quadratic bottom drag [L2 T-2 ~> m2 s-2]. real :: hwtot ! Sum of the thicknesses used to calculate ! the near-bottom velocity magnitude [H ~> m or kg m-2]. real :: hutot ! Running sum of thicknesses times the diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index e7303e54f7..d1f1adc136 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -580,7 +580,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure ! Field from forces used in this subroutine: - ! ustar: the friction velocity [m s-1], used here as the mixing + ! ustar: the friction velocity [Z T-1 ~> m s-1], used here as the mixing ! velocity in the mixed layer if NKML > 1 in a bulk mixed layer. ! Local variables From d518449d4ccc84a634b08762f2bf010b1466a424 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 19:44:23 -0400 Subject: [PATCH 180/259] Corrected units in MOM_hor_visc code comments Cleanup of units in comments in MOM_hor_visc. All answers are bitwise identical. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2b78d4594a..010b10e7f4 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -261,9 +261,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, boundary_mask ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G)) :: & - dvdx, dudy, & ! components in the shearing strain [T-1 s-1] + dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] - dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [T-1 s-1] + dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [T-1 ~> s-1] sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [T-1 ~> s-1] str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2] @@ -1511,8 +1511,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ! [T2 L-2 ~> s2 m-2] real :: Ah_Limit ! coefficient [T-1 ~> s-1] used, along with the ! grid spacing, to limit biharmonic viscosity - real :: Kh ! Lapacian horizontal viscosity [L2 s-1] - real :: Ah ! biharmonic horizontal viscosity [L4 s-1] + real :: Kh ! Lapacian horizontal viscosity [L2 T-1 ~> m2 s-1] + real :: Ah ! biharmonic horizontal viscosity [L4 T-1 ~> m4 s-1] real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Lap visc real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives bih visc real :: Ah_time_scale ! damping time-scale for biharmonic visc [T ~> s] From 629416b74f8a9f342f68d96cba4310f3ac416e3a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 8 Oct 2019 19:50:17 -0400 Subject: [PATCH 181/259] +Rescaled the units of tv%salt_deficit +Rescaled the units of tv%salt_deficit to units of [ppt R Z] for greater dimensional consistency testing and for code simplification. This also required adding a unit_scale_type argument to MOM_thermo_chksum. All answers are bitwise identical, but there is a new subroutine argument. --- src/core/MOM.F90 | 14 +++++++------- src/core/MOM_checksum_packages.F90 | 6 ++++-- src/core/MOM_variables.F90 | 4 ++-- src/diagnostics/MOM_diagnostics.F90 | 2 +- .../vertical/MOM_diabatic_aux.F90 | 6 +++--- 5 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 226fde6810..69835d6dcf 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1079,8 +1079,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, & "Pre-advection frazil", G%HI, haloshift=0) if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & - "Pre-advection salt deficit", G%HI, haloshift=0) - ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G) + "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%R_to_kg_m3*US%Z_to_m) + ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G, US) call cpu_clock_end(id_clock_other) endif @@ -1186,7 +1186,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & haloshift=0, scale=GV%H_to_m*US%L_to_m**2) ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) - call MOM_thermo_chksum("Pre-diabatic ", tv, G,haloshift=0) + call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) call check_redundant("Pre-diabatic ", u, v, G) call MOM_forcing_chksum("Pre-diabatic", fluxes, G, US, haloshift=0) endif @@ -1268,8 +1268,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (associated(tv%frazil)) call hchksum(tv%frazil, & "Post-diabatic frazil", G%HI, haloshift=0) if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & - "Post-diabatic salt deficit", G%HI, haloshift=0) - ! call MOM_thermo_chksum("Post-diabatic ", tv, G) + "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%R_to_kg_m3*US%Z_to_m) + ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) call check_redundant("Post-diabatic ", u, v, G) endif call disable_averaging(CS%diag) @@ -2910,7 +2910,7 @@ subroutine extract_surface_state(CS, sfc_state) if (G%mask2dT(i,j)>0.) then ! instantaneous melt_potential [J m-2] - sfc_state%melt_potential(i,j) = CS%tv%C_p * CS%US%R_to_kg_m3*GV%Rho0 * delT(i) + sfc_state%melt_potential(i,j) = CS%tv%C_p * US%R_to_kg_m3*GV%Rho0 * delT(i) endif enddo enddo ! end of j loop @@ -2920,7 +2920,7 @@ subroutine extract_surface_state(CS, sfc_state) !$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 * US%R_to_kg_m3*US%Z_to_m*CS%tv%salt_deficit(i,j) enddo ; enddo endif if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index e8347881f7..659ca478ed 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -117,11 +117,12 @@ end subroutine MOM_state_chksum_3arg ! ============================================================================= !> Write out chksums for the model's thermodynamic state variables. -subroutine MOM_thermo_chksum(mesg, tv, G, haloshift) +subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). integer :: is, ie, js, je, nz, hs @@ -131,7 +132,8 @@ subroutine MOM_thermo_chksum(mesg, tv, G, haloshift) if (associated(tv%T)) call hchksum(tv%T, mesg//" T",G%HI,haloshift=hs) if (associated(tv%S)) call hchksum(tv%S, mesg//" S",G%HI,haloshift=hs) if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil",G%HI,haloshift=hs) - if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, mesg//" salt deficit",G%HI,haloshift=hs) + if (associated(tv%salt_deficit)) & + call hchksum(tv%salt_deficit, mesg//" salt deficit",G%HI,haloshift=hs, scale=US%R_to_kg_m3*US%Z_to_m) end subroutine MOM_thermo_chksum diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 774a636daa..dc84c66930 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -101,7 +101,7 @@ module MOM_variables real, dimension(:,:), pointer :: salt_deficit => NULL() !< The salt needed to maintain the ocean column !! at a minimum salinity of MIN_SALINITY since the last time - !! that calculate_surface_state was called, [gSalt m-2]. + !! that calculate_surface_state was called, [ppt R Z ~> gSalt m-2]. real, dimension(:,:), pointer :: TempxPmE => NULL() !< The net inflow of water into the ocean times the !! temperature at which this inflow occurs since the @@ -465,7 +465,7 @@ subroutine MOM_thermovar_chksum(mesg, tv, G) if (associated(tv%frazil)) & call hchksum(tv%frazil, mesg//" tv%frazil", G%HI) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI) + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=G%US%R_to_kg_m3*G%US%Z_to_m) if (associated(tv%TempxPmE)) & call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=G%US%R_to_kg_m3*G%US%Z_to_m) end subroutine MOM_thermovar_chksum diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7e5adbb1d3..3fd7d3cafc 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1794,7 +1794,7 @@ subroutine register_surface_diags(Time, G, IDs, diag, tv) 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') + 'Salt sink in ocean due to ice flux', 'psu m-2 s-1', conversion=G%US%R_to_kg_m3*G%US%Z_to_m) 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', conversion=G%US%R_to_kg_m3*G%US%Z_to_m) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index d8c7517542..5ed7d02829 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -334,9 +334,9 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) integer, optional, intent(in) :: halo !< Halo width over which to work ! local variables - real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement [gSalt m-2] + real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement [ppt R Z ~> gSalt m-2] real :: S_min !< The minimum salinity [ppt]. - real :: mc !< A layer's mass [kg m-2]. + real :: mc !< A layer's mass [R Z ~> kg m-2]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -355,7 +355,7 @@ subroutine adjust_salt(h, tv, G, GV, CS, halo) do k=nz,1,-1 ; do i=is,ie if ( (G%mask2dT(i,j) > 0.0) .and. & ((tv%S(i,j,k) < S_min) .or. (salt_add_col(i,j) > 0.0)) ) then - mc = GV%H_to_kg_m2 * h(i,j,k) + mc = GV%H_to_RZ * h(i,j,k) if (h(i,j,k) <= 10.0*GV%Angstrom_H) then ! Very thin layers should not be adjusted by the salt flux if (tv%S(i,j,k) < S_min) then From 12d3aac4d1c5f3ae4e6bf38d1ce0fd798371cd13 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 10 Oct 2019 09:49:01 -0400 Subject: [PATCH 182/259] T scaling and OpenMP fixes This adds dimensional scaling to the vprec diagnostic, and resolves some variable name changes and additions to the OpenMP directives. This fixes some of the tests in GitHub PR 1019. --- src/core/MOM_PressureForce_blocked_AFV.F90 | 4 ++-- src/core/MOM_forcing_type.F90 | 5 +++-- src/core/MOM_isopycnal_slopes.F90 | 2 +- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 2 +- src/parameterizations/vertical/MOM_geothermal.F90 | 2 +- src/parameterizations/vertical/MOM_internal_tide_input.F90 | 2 +- src/parameterizations/vertical/MOM_regularize_layers.F90 | 2 +- src/parameterizations/vertical/MOM_set_viscosity.F90 | 4 ++-- src/parameterizations/vertical/MOM_vert_friction.F90 | 4 ++-- 9 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index eb021a18e4..faa7912f1e 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -630,8 +630,8 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, endif !$OMP parallel do default(none) shared(use_p_atm,Rho_ref,Rho_ref_mks,G,GV,e,p_atm,nz,use_EOS,& -!$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp,g_Earth_z, & -!$OMP h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& +!$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp,g_Earth_z_geo, & +!$OMP g_Earth_mks_z,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, & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 47645eb57a..bcf23e62db 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -855,7 +855,7 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt_in_T, FluxRescaleD logical, intent(in) :: aggregate_FW !< For determining how to aggregate the forcing. integer :: j -!$OMP parallel do default(none) shared(G, GV, fluxes, optics, nsw,dt,FluxRescaleDepth, & +!$OMP parallel do default(none) shared(G, GV, US, fluxes, optics, nsw, dt_in_T, FluxRescaleDepth, & !$OMP useRiverHeatContent, useCalvingHeatContent, & !$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & !$OMP aggregate_FW) @@ -1320,7 +1320,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea') handles%id_vprec = register_diag_field('ocean_model', 'vprec', diag%axesT1, Time, & - 'Virtual liquid precip into ocean due to SSS restoring', 'kg m-2 s-1') + 'Virtual liquid precip into ocean due to SSS restoring', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_frunoff = register_diag_field('ocean_model', 'frunoff', diag%axesT1, Time, & 'Frozen runoff (calving) and iceberg melt into ocean', 'kg m-2 s-1', & diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 282898975e..fc60d54f10 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -243,7 +243,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & enddo ; enddo ! end of j-loop ! Calculate the meridional isopycnal slope. - !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,pres,T,S,tv, & + !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 5ed7d02829..4b94593715 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -971,7 +971,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, if (CS%id_createdH>0) CS%createdH(:,:) = 0. numberOfGroundings = 0 - !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,US,optics,fluxes,dt, & + !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,US,optics,fluxes, & !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & !$OMP minimum_forcing_depth,evap_CFL_limit,dt_in_T, & diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 8deae74450..a7c8338572 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -157,7 +157,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) if (compute_h_old) h_old(:,:,:) = 0.0 if (compute_T_old) T_old(:,:,:) = 0.0 -!$OMP parallel do default(none) shared(is,ie,js,je,G,GV,CS,dt,Irho_cp,nkmb,tv, & +!$OMP parallel do default(none) shared(is,ie,js,je,G,GV,US,CS,dt,Irho_cp,nkmb,tv, & !$OMP p_Ref,h,Angstrom,nz,H_neglect,eb, & !$OMP compute_h_old,compute_T_old,h_old,T_old, & !$OMP work_3d,Idt) & diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index feb5c3d45c..7f43067360 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -190,7 +190,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) do i=is,ie dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,h,T_f,S_f, & +!$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & !$OMP h2,N2_bot,G_Rho0) & !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & !$OMP hb,dRho_bot,z_from_bot,do_i,h_amp, & diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index d2b326bac6..ff352d5e32 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -300,7 +300,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! Now restructure the layers. -!$OMP parallel do default(none) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,& +!$OMP parallel do default(none) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & !$OMP eb,id_clock_EOS,nkml) & !$OMP private(d_ea,d_eb,max_def_rat,do_i,nz_filt,e_e,e_w,& diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 73193e4a25..830d159a29 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1193,7 +1193,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym endif enddo ; endif - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt_in_T,G,GV,US,CS,use_EOS,dt_Rho0, & !$OMP h_neglect,h_tiny,g_H_Rho0,js,je,OBC,Isq,Ieq,nz, & !$OMP U_bg_sq,mask_v,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml) do j=js,je ! u-point loop @@ -1428,7 +1428,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym enddo ! j-loop at u-points - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt_in_T,G,GV,US,CS,use_EOS,dt_Rho0, & !$OMP h_neglect,h_tiny,g_H_Rho0,is,ie,OBC,Jsq,Jeq,nz, & !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml,mask_u) do J=Jsq,Jeq ! v-point loop diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d1f1adc136..bf1c671028 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -671,7 +671,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) endif !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_u) & + !$OMP OBC,h_neglect,dt_in_T,I_valBL,Kv_u) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo @@ -838,7 +838,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) ! Now work on v-points. !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_v) & + !$OMP OBC,h_neglect,dt_in_T,I_valBL,Kv_v) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo From 28bc95e0cf9d91e132633b10ed025c9c41c33608 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 11 Oct 2019 10:40:13 -0400 Subject: [PATCH 183/259] Makefile: MPI flag test; REPRO flag; diff report This patch fixes several issues with the current test suite Makefile: - the DO_REPRO_TEST flag is now available to disable the REPRO=1 test, which currently fails on older GCC compilers and Intel compilers. This may be expected, and needs further investigation. - Regression tests against PR targets had been inadvertently disabled due to a misnamed variable (TEST vs TESTS). This has been fixed. - OpenMP tests have been added to the suite. Success may vary... - We now report a full diff output for a failed cmp test of stats and diagnostic checksums - tab indentation was being used outside the context of rule definitions. This was not causing issues but has been replaced with space intents to avoid future problems. Note that OpenMP testing issues were observed on an older GCC compiler, but it's not clear if this will persist on Travis or more modern GCC compilers, and may be disabled (or perhaps even fixed) in a future commit. --- .testing/Makefile | 59 +++++++++++++++++++++++++++++------------------ 1 file changed, 37 insertions(+), 22 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 0cd5454e3d..1d0b6d17ba 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -1,8 +1,12 @@ SHELL = bash -MPIRUN ?= mpirun +# User-defined configuration -include config.mk +# Default configurations +MPIRUN ?= mpirun +DO_REPRO_TESTS ?= true + #--- # Dependencies BASE = $(dir $(abspath $(lastword $(MAKEFILE_LIST))))/.. @@ -38,36 +42,45 @@ MKMF_TEMPLATE ?= $(DEPS)/mkmf/templates/ncrc-gnu.mk # Executables BUILDS = symmetric asymmetric repro openmp CONFIGS := $(wildcard tc*) -TESTS = grids layouts restarts repros nans dims +TESTS = grids layouts restarts nans dims openmps + +# REPRO tests enable reproducibility with optimization, and often do not match +# the DEBUG results in older GCCs and vendor compilers, so we can optionally +# disable them. +ifeq ($(DO_REPRO_TESTS), true) + BUILDS += repro + TESTS += repros +endif # The following variables are configured by Travis: # DO_REGRESSION_TESTS: true if $(TRAVIS_PULL_REQUEST) is a PR number # MOM_TARGET_SLUG: TRAVIS_REPO_SLUG # MOM_TARGET_LOCAL_BRANCH: TRAVIS_BRANCH -# -# These are set to true by Travis if testing a pull request + +# These are set to true by our Travis configuration if testing a pull request DO_REGRESSION_TESTS ?= REPORT_COVERAGE ?= ifeq ($(DO_REGRESSION_TESTS), true) - BUILDS += target - TEST += regressions + BUILDS += target + TESTS += regressions - MOM_TARGET_SLUG ?= NOAA-GFDL/MOM6 - MOM_TARGET_URL ?= https://github.com/$(MOM_TARGET_SLUG) + MOM_TARGET_SLUG ?= NOAA-GFDL/MOM6 + MOM_TARGET_URL ?= https://github.com/$(MOM_TARGET_SLUG) - MOM_TARGET_LOCAL_BRANCH ?= dev/gfdl - MOM_TARGET_BRANCH := origin/$(MOM_TARGET_LOCAL_BRANCH) + MOM_TARGET_LOCAL_BRANCH ?= dev/gfdl + MOM_TARGET_BRANCH := origin/$(MOM_TARGET_LOCAL_BRANCH) - TARGET_CODEBASE = $(BUILD)/target_codebase + TARGET_CODEBASE = $(BUILD)/target_codebase else - MOM_TARGET_URL = - MOM_TARGET_BRANCH = - TARGET_CODEBASE = + MOM_TARGET_URL = + MOM_TARGET_BRANCH = + TARGET_CODEBASE = endif SOURCE = $(wildcard $(BASE)/src/*/*.F90 $(BASE)/src/*/*/*.F90 $(BASE)/config_src/solo_driver/*.F90) + #--- # Rules @@ -175,15 +188,14 @@ test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) test.dims: $(foreach c,$(CONFIGS),$(foreach d,t l h z,$(c).dim.$(d) $(c).dim.$(d).diag)) -# NOTE: chksum_diag return code of cmp is currently ignored since many fail! define CMP_RULE .PRECIOUS: $(foreach b,$(2),results/%/ocean.stats.$(b)) %.$(1): $(foreach b,$(2),results/%/ocean.stats.$(b)) - cmp $$^ + cmp $$^ || diff $$^ .PRECIOUS: $(foreach b,$(2),results/%/chksum_diag.$(b)) %.$(1).diag: $(foreach b,$(2),results/%/chksum_diag.$(b)) - cmp $$^ + cmp $$^ || diff $$^ endef $(eval $(call CMP_RULE,regression,symmetric target)) @@ -197,7 +209,8 @@ $(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) # Restart tests only compare the final stat record .PRECIOUS: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) %.restart: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) - cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) + cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ + || diff $^ # TODO: chksum_diag parsing of restart files @@ -205,12 +218,14 @@ $(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) #--- # Test run output files -# Simple function for generalized Slurm (srun) and OpenMPI (mpirun) support +# Generalized MPI environment variable support # $(1): Environment variables -ifeq ($(MPIRUN), srun) -MPIRUN_CMD=$(1) $(MPIRUN) +ifeq ($(shell $(MPIRUN) -x tmp=1 true 2> /dev/null ; echo $$?), 0) + MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) +else ifeq ($(shell $(MPIRUN) -env tmp=1 true 2> /dev/null ; echo $$?), 0) + MPIRUN_CMD=$(MPIRUN) $(if $(1),-env $(1),) else -MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) + MPIRUN_CMD=$(1) $(MPIRUN) endif # Rule to build results//{ocean.stats,chksum_diag}. From 79a8fe2aa515e8b5dd9ac2fdb334ae096daf2695 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 16 Oct 2019 11:00:17 -0400 Subject: [PATCH 184/259] Ice shelf and barotropic rescale variable init Some index bounds in the ice shelf code were not initialized to the grid values. This patch sets those values. The vel_rescale parameter used in barotropic_init was also absent from one block of code, and has been added. (This is probably a temporary variable that will be phased out as dimensional scaling progresses.) Presumably none of this code was being run, because it would have normally caused severe problems. --- src/core/MOM_barotropic.F90 | 1 + src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 3 +++ 2 files changed, 4 insertions(+) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7984fa97ce..5f97f5933a 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4310,6 +4310,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, enddo ; enddo ; enddo elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then + vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(I,j) ; enddo ; enddo endif diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 5e53c09923..80f2d8f60f 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -287,6 +287,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ logical :: debug integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + if (.not.associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn: "// & "called with an associated control structure.") From 5f81b735947290c90312e87a5f867ff0870c19c9 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 18 Oct 2019 11:51:06 -0400 Subject: [PATCH 185/259] Fix the downsampled "summed" diagnostics - Steve and Mike noticed that the downsampled2 umo,vmo in 1/8 degree runs are smaller than the corresponding 1/4 degree run diagnostics by almost a factor of 2. I have confirmed this discrepancy for the magnitudes of umo,vmo in the same 1/8 degree run between the downsampled and original. - The issue stems from calculating the mean rather the sum for diagnostics PSS and SPS where the quantities have to be summed over the two fine cells. - This bug also affects SSS d2 diagnostics such as volcello. - Also, I deleted the suspect logic for PSM diagnostics which I think are non-existant in MOM6. - I have tested this in a low resolution model run and it seems to have worked. --- src/framework/MOM_diag_mediator.F90 | 27 +++------------------------ 1 file changed, 3 insertions(+), 24 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 674046a750..8f762dedd5 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3880,14 +3880,11 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 - total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj,k) - total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight enddo; enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo elseif(method .eq. MMP .or. method .eq. MMS) then !e.g., T_advection_xy do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -3917,47 +3914,29 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PSM) then - do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d - i0 = isv_o+dl*(i-isv_d) - j0 = jsv_o+dl*(j-jsv_d) - ave = 0.0 - total_weight = 0.0 - ii=i0 - do jj=j0,j0+dl-1 - weight =mask(ii,jj,k)*diag_cs%h(ii,jj,k) - total_weight = total_weight +weight - ave=ave+field_in(ii,jj,k)*weight - enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 - enddo; enddo; enddo elseif(method .eq. PSS) then !e.g. umo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 - total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 weight =mask(ii,jj,k) - total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo elseif(method .eq. SPS) then !e.g. vmo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 - total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 weight =mask(ii,jj,k) - total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo elseif(method .eq. MPM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d From defb0c59dd4d54ab0a9b2c069f5550dd737a5181 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 24 Oct 2019 21:15:09 -0400 Subject: [PATCH 186/259] Verify ENABLE_THERMODYNAMICS is True before posting C_p diagnostic --- src/diagnostics/MOM_diagnostics.F90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7344a5e677..5a05a9a453 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1859,7 +1859,8 @@ subroutine write_static_fields(G, GV, US, tv, diag) ! Local variables integer :: id - + logical :: use_temperature + id = register_static_field('ocean_model', 'geolat', diag%axesT1, & 'Latitude of tracer (T) points', 'degrees_north') if (id > 0) call post_data(id, G%geoLatT, diag, .true.) @@ -2011,12 +2012,15 @@ subroutine write_static_fields(G, GV, US, tv, diag) cmor_long_name='reference sea water density for boussinesq approximation') if (id > 0) call post_data(id, GV%Rho0, diag, .true.) - 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, tv%C_p, diag, .true.) - + use_temperature = associated(tv%T) + if (use_temperature) then + 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, tv%C_p, diag, .true.) + endif + end subroutine write_static_fields From 3c0d52ac8a93465f0ff3d29fb72587eb75d9a35e Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 25 Oct 2019 10:47:30 -0400 Subject: [PATCH 187/259] Make tc4 faster --- .testing/tc4/MOM_input | 9 +++++++-- .testing/tc4/build_data.py | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index 456783af88..deb496315a 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -7,10 +7,15 @@ USE_REGRIDDING = True ! [Boolean] default = False ! If True, use the ALE algorithm (regridding/remapping). If False, use the ! layered isopycnal algorithm. -DT = 300.0 ! [s] +DT = 1200.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that is actually used will ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode ! or the coupling timestep in coupled mode.) +DT_THERM = 3600.0 ! [s] default = 300.0 + ! The thermodynamic and tracer advection time step. Ideally DT_THERM should be + ! an integer multiple of DT and less than the forcing or coupling time-step, + ! unless THERMO_SPANS_COUPLING is true, in which case DT_THERM can be an integer + ! multiple of the coupling timestep. By default DT_THERM is set to DT. C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 ! The heat capacity of sea water, approximated as a constant. This is only used ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 @@ -377,7 +382,7 @@ WIND_CONFIG = "zero" ! ! === module MOM_restart === ! === module MOM_main (MOM_driver) === -DAYMAX = 1.0 ! [days] +DAYMAX = 0.25 ! [days] ! The final time of the whole simulation, in units of TIMEUNIT seconds. This ! also sets the potential end time of the present run segment if the end time is ! not set via ocean_solo_nml in input.nml. diff --git a/.testing/tc4/build_data.py b/.testing/tc4/build_data.py index 50f45ce9f1..e060d05cb1 100644 --- a/.testing/tc4/build_data.py +++ b/.testing/tc4/build_data.py @@ -30,7 +30,7 @@ def t_fc(x, y, z, radius=5.0, tmag=1.0): ny, nx = x.shape -nz = 10 +nz = 3 z = (np.arange(nz) * zbot0) / nz temp = t_fc(x, y, z) From 817bdde76ccd24490786e5dd2554077b0b79f7e9 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 25 Oct 2019 10:54:12 -0400 Subject: [PATCH 188/259] remove trailing whitespace --- src/diagnostics/MOM_diagnostics.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 5a05a9a453..b8696969df 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1860,7 +1860,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) ! Local variables integer :: id logical :: use_temperature - + id = register_static_field('ocean_model', 'geolat', diag%axesT1, & 'Latitude of tracer (T) points', 'degrees_north') if (id > 0) call post_data(id, G%geoLatT, diag, .true.) @@ -2012,7 +2012,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) cmor_long_name='reference sea water density for boussinesq approximation') if (id > 0) call post_data(id, GV%Rho0, diag, .true.) - use_temperature = associated(tv%T) + use_temperature = associated(tv%T) if (use_temperature) then id = register_static_field('ocean_model','C_p', diag%axesNull, & 'heat capacity of sea water', 'J kg-1 K-1', cmor_field_name='cpocean', & @@ -2020,7 +2020,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) cmor_long_name='specific_heat_capacity_of_sea_water') if (id > 0) call post_data(id, tv%C_p, diag, .true.) endif - + end subroutine write_static_fields From 231f1204b035297bd8e1f37c112b5c9fb1c572ab Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 29 Oct 2019 10:16:38 -0400 Subject: [PATCH 189/259] add unit scaling --- .testing/tc4/MOM_input | 5 +++++ src/initialization/MOM_state_initialization.F90 | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index deb496315a..2b08e9bccb 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -386,6 +386,11 @@ DAYMAX = 0.25 ! [days] ! The final time of the whole simulation, in units of TIMEUNIT seconds. This ! also sets the potential end time of the present run segment if the end time is ! not set via ocean_solo_nml in input.nml. + +ENERGYSAVEDAYS = 0.125 ! [days] default = 1.44E+04 + ! The interval in units of TIMEUNIT between saves of the + ! energies of the run and other globally summed diagnostics. + RESTART_CONTROL = 3 ! default = 1 ! An integer whose bits encode which restart files are written. Add 2 (bit 1) ! for a time-stamped file, and odd (bit 0) for a non-time-stamped file. A diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 1f5401ee58..bfebf95c08 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1864,8 +1864,8 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) call set_up_sponge_field(tmp, tv%S, G, nz, CSp) elseif (use_temperature) then - call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, tv%T, ALE_CSp) - call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, tv%S, ALE_CSp) + call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp) + call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp) endif end subroutine initialize_sponges_file From c4606e1d03143a0bdefa0690541393612d7aa0be Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 29 Oct 2019 10:17:42 -0400 Subject: [PATCH 190/259] fix restart fail for tc4 and some cleanup --- .../vertical/MOM_ALE_sponge.F90 | 223 ++++++------------ 1 file changed, 66 insertions(+), 157 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 17b601427c..89229c642d 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -11,7 +11,6 @@ module MOM_ALE_sponge ! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl @@ -24,7 +23,6 @@ module MOM_ALE_sponge use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -! GMM - Planned extension: Support for time varying sponge targets. implicit none ; private @@ -129,7 +127,7 @@ module MOM_ALE_sponge type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays - logical :: new_sponges !< True if using newer sponge code + logical :: time_varying_sponges !< True if using newer sponge code logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid end type ALE_sponge_CS @@ -195,7 +193,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) - CS%new_sponges = .false. + CS%time_varying_sponges = .false. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -370,7 +368,7 @@ subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) end subroutine get_ALE_sponge_thicknesses -!> This subroutine determines the number of points which are within sponges in this computational +!> This subroutine determines the number of points which are to be restoref in the computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean !! points are included in the sponges. subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) @@ -382,8 +380,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). - - ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. @@ -394,45 +390,38 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme + if (associated(CS)) then call MOM_error(WARNING, "initialize_sponge called with an associated "// & "control structure.") return endif - ! Set default, read and log parameters call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SPONGE", use_sponge, & "If true, sponges may be applied anywhere in the domain. "//& "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) - if (.not.use_sponge) return - allocate(CS) - call get_param(param_file, mdl, "SPONGE_UV", CS%sponge_uv, & "Apply sponges in u and v, in addition to tracers.", & default=.false.) - call get_param(param_file, mdl, "REMAPPING_SCHEME", remapScheme, & "This sets the reconstruction scheme used "//& " for vertical remapping for all variables.", & default="PLM", do_not_log=.true.) - call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION", bndExtrapolation, & "When defined, a proper high-order reconstruction "//& "scheme is used within boundary cells rather "//& "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & default=.false.) - - CS%new_sponges = .true. + CS%time_varying_sponges = .true. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -444,8 +433,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & CS%num_col = CS%num_col + 1 enddo ; enddo - - if (CS%num_col > 0) then allocate(CS%Iresttime_col(CS%num_col)) ; CS%Iresttime_col = 0.0 allocate(CS%col_i(CS%num_col)) ; CS%col_i = 0 @@ -460,21 +447,16 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) endif enddo ; enddo endif - total_sponge_cols = CS%num_col call sum_across_PEs(total_sponge_cols) ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation) - call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.") - if (CS%sponge_uv) then - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 - ! u points CS%num_col_u = 0 ; !CS%fldno_u = 0 do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB @@ -482,13 +464,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo - if (CS%num_col_u > 0) then - allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 - ! pass indices, restoring time to the CS structure col = 1 do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB @@ -498,15 +477,12 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) col = col +1 endif enddo ; enddo - ! same for total number of arbritary layers and correspondent data - endif total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & "The total number of columns where sponges are applied at u points.") - ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec @@ -514,13 +490,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo - if (CS%num_col_v > 0) then - allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 - ! pass indices, restoring time to the CS structure col = 1 do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec @@ -530,7 +503,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) col = col +1 endif enddo ; enddo - endif total_sponge_cols_v = CS%num_col_v call sum_across_PEs(total_sponge_cols_v) @@ -594,7 +566,7 @@ end subroutine set_up_ALE_sponge_field_fixed !> This subroutine stores the reference profile at h points for the variable !! whose address is given by filename and fieldname. -subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_ptr, CS) +subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, f_ptr, CS) character(len=*), intent(in) :: filename !< The name of the file with the !! time varying field data character(len=*), intent(in) :: fieldname !< The name of the field in the file @@ -602,6 +574,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< Grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). @@ -617,101 +590,42 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_p integer, dimension(4) :: fld_sz integer :: nz_data !< the number of vertical levels in this input field character(len=256) :: mesg ! String for error messages - ! Local variables for ALE remapping - real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. real, dimension(:), allocatable :: tmpT1d real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays if (.not.associated(CS)) return - - ! Call this in case it was not previously done. + ! initialize time interpolator module call time_interp_external_init() - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed CS%fldno = CS%fldno + 1 - if (CS%fldno > MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & &initialize_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif - - ! get a unique id for this field which will allow us to return an array - ! containing time-interpolated values from an external file corresponding - ! to the current model date. - + ! get a unique time interp id for this field. If sponge data is ongrid, then setup + ! to only read on the computational domain if (CS%spongeDataOngrid) then CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname,domain=G%Domain%mpp_domain) else CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) endif - fld_sz(1:4)=-1 fld_sz = get_external_field_size(CS%Ref_val(CS%fldno)%id) nz_data = fld_sz(3) - CS%Ref_val(CS%fldno)%nz_data = nz_data !< each individual sponge field is assumed to reside on a different grid + CS%Ref_val(CS%fldno)%nz_data = nz_data !< individual sponge fields may reside on a different vertical grid CS%Ref_val(CS%fldno)%num_tlevs = fld_sz(4) - - allocate( sp_val(isd:ied,jsd:jed, nz_data) ) - allocate( mask_z(isd:ied,jsd:jed, nz_data) ) - - ! initializes the current reference profile array + ! initializes the target profile array for this field + ! for all columns which will be masked allocate(CS%Ref_val(CS%fldno)%p(nz_data,CS%num_col)) CS%Ref_val(CS%fldno)%p(:,:) = 0.0 allocate( CS%Ref_val(CS%fldno)%h(nz_data,CS%num_col) ) CS%Ref_val(CS%fldno)%h(:,:) = 0.0 - - ! Interpolate external file data to the model grid - ! I am hard-wiring this call to assume that the input grid is zonally re-entrant - ! In the future, this should be generalized using an interface to return the - ! modulo attribute of the zonal axis (mjh). - -! call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & -! missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) - - ! Do not think halo updates are needed (mjh) -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) - - ! Done with horizontal interpolation. - ! Now remap to model coordinates - ! First we reserve a work space for reconstructions of the source data - allocate( hsrc(nz_data) ) - allocate( tmpT1d(nz_data) ) - - do col=1,CS%num_col - ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 - do k=1,nz_data - if (mask_z(CS%col_i(col),CS%col_j(col),k) == 1.0) then - zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(CS%col_i(col),CS%col_j(col)) ) -! tmpT1d(k) = sp_val(CS%col_i(col),CS%col_j(col),k) - elseif (k>1) then - zBottomOfCell = -G%bathyT(CS%col_i(col),CS%col_j(col)) -! tmpT1d(k) = tmpT1d(k-1) -! else ! This next block should only ever be reached over land -! tmpT1d(k) = -99.9 - endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 - zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k - enddo - ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(col),CS%col_j(col)) ) - CS%Ref_val(CS%fldno)%h(1:nz_data,col) = 0. - CS%Ref_val(CS%fldno)%p(1:nz_data,col) = -1.e24 - CS%Ref_val(CS%fldno)%h(1:nz_data,col) = GV%Z_to_H*hsrc(1:nz_data) -! CS%Ref_val(CS%fldno)%p(1:nz_data,col) = tmpT1d(1:nz_data) - enddo - CS%var(CS%fldno)%p => f_ptr - deallocate( hSrc ) - deallocate( tmpT1d ) - deallocate(sp_val, mask_z) end subroutine set_up_ALE_sponge_field_varying @@ -740,9 +654,7 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) CS%Ref_val_u%p(k,col) = u_val(CS%col_i_u(col),CS%col_j_u(col),k) enddo enddo - CS%var_u%p => u_ptr - allocate(CS%Ref_val_v%p(CS%nz_data,CS%num_col_v)) CS%Ref_val_v%p(:,:) = 0.0 do col=1,CS%num_col_v @@ -750,7 +662,6 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) CS%Ref_val_v%p(k,col) = v_val(CS%col_i_v(col),CS%col_j_v(col),k) enddo enddo - CS%var_v%p => v_ptr end subroutine set_up_ALE_sponge_vel_field_fixed @@ -788,46 +699,36 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed isdB = G%isdB; iedB = G%iedB; jsdB = G%jsdB; jedB = G%jedB - ! get a unique id for this field which will allow us to return an array ! containing time-interpolated values from an external file corresponding ! to the current model date. - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) fld_sz(1:4)=-1 fld_sz = get_external_field_size(CS%Ref_val_u%id) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) fld_sz(1:4)=-1 fld_sz = get_external_field_size(CS%Ref_val_v%id) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) - allocate( u_val(isdB:iedB,jsd:jed, fld_sz(3)) ) allocate( mask_u(isdB:iedB,jsd:jed, fld_sz(3)) ) allocate( v_val(isd:ied,jsdB:jedB, fld_sz(3)) ) allocate( mask_v(isd:ied,jsdB:jedB, fld_sz(3)) ) - ! Interpolate external file data to the model grid ! I am hard-wiring this call to assume that the input grid is zonally re-entrant ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,u_val,mask_u,z_in,z_edges_in,& missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) - !!! TODO: add a velocity interface! (mjh) - ! Interpolate external file data to the model grid ! I am hard-wiring this call to assume that the input grid is zonally re-entrant ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,v_val,mask_v,z_in,z_edges_in, & missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) - ! stores the reference profile allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u)) CS%Ref_val_u%p(:,:) = 0.0 @@ -836,9 +737,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_u%p(k,col) = u_val(CS%col_i_u(col),CS%col_j_u(col),k) enddo enddo - CS%var_u%p => u_ptr - allocate(CS%Ref_val_v%p(fld_sz(3),CS%num_col_v)) CS%Ref_val_v%p(:,:) = 0.0 do col=1,CS%num_col_v @@ -846,7 +745,6 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename CS%Ref_val_v%p(k,col) = v_val(CS%col_i_v(col),CS%col_j_v(col),k) enddo enddo - CS%var_v%p => v_ptr end subroutine set_up_ALE_sponge_vel_field_varying @@ -874,13 +772,18 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: hv(SZI_(G), SZJB_(G), SZK_(G)) ! A temporary array for h at v pts real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts + real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. + ! Local variables for ALE remapping + real, dimension(:), allocatable :: tmpT1d integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data + integer :: col, total_sponge_cols real, allocatable, dimension(:), target :: z_in, z_edges_in real :: missing_value real :: h_neglect, h_neglect_edge - + real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. + integer :: nPoints + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - if (.not.associated(CS)) return if (GV%Boussinesq) then @@ -889,46 +792,57 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 endif - if (CS%new_sponges) then + if (CS%time_varying_sponges) then if (.not. present(Time)) & call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") - -! Interpolate new grid in time-space do m=1,CS%fldno - - nz_data = CS%Ref_val(m)%nz_data - allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) - allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) - sp_val(:,:,:)=0.0 - mask_z(:,:,:)=0.0 - - call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z,spongeOnGrid=CS%SpongeDataOngrid) - -! call pass_var(sp_val,G%Domain) -! call pass_var(mask_z,G%Domain) - - - do c=1,CS%num_col - i = CS%col_i(c) ; j = CS%col_j(c) - CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) - do k=2,nz_data -! if (mask_z(i,j,k)==0.) & - if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & - ! some confusion here about why the masks are not correct returning from horiz_interp - ! reverting to using a minimum thickness criteria - CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) - enddo + nz_data = CS%Ref_val(m)%nz_data + allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) + allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) + sp_val(:,:,:)=0.0 + mask_z(:,:,:)=0.0 + call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & + missing_value,.true., .false.,.false.,spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z) + allocate( hsrc(nz_data) ) + allocate( tmpT1d(nz_data) ) + do c=1,CS%num_col + i = CS%col_i(c) ; j = CS%col_j(c) + CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) + ! Build the source grid + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + do k=1,nz_data + if (mask_z(CS%col_i(c),CS%col_j(c),k) == 1.0) then + zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(CS%col_i(c),CS%col_j(c)) ) + tmpT1d(k) = sp_val(CS%col_i(c),CS%col_j(c),k) + elseif (k>1) then + zBottomOfCell = -G%bathyT(CS%col_i(c),CS%col_j(c)) + tmpT1d(k) = tmpT1d(k-1) + else ! This next block should only ever be reached over land + tmpT1d(k) = -99.9 + endif + hsrc(k) = zTopOfCell - zBottomOfCell + if (hsrc(k)>0.) nPoints = nPoints + 1 + zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k + enddo + ! In case data is deeper than model + hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(c),CS%col_j(c)) ) + CS%Ref_val(CS%fldno)%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + CS%Ref_val(CS%fldno)%p(1:nz_data,c) = tmpT1d(1:nz_data) + do k=2,nz_data + ! if (mask_z(i,j,k)==0.) & + if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & + ! some confusion here about why the masks are not correct returning from horiz_interp + ! reverting to using a minimum thickness criteria + CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) + enddo enddo - - deallocate(sp_val, mask_z) + deallocate(sp_val, mask_z, hsrc, tmpT1d) enddo else nz_data = CS%nz_data endif allocate(tmp_val2(nz_data)) - do m=1,CS%fldno do c=1,CS%num_col ! c is an index for the next 3 lines but a multiplier for the rest of the loop @@ -937,7 +851,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) damp = dt*CS%Iresttime_col(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) - if (CS%new_sponges) then + if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%h(1:nz_data,c), tmp_val2, & CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else @@ -946,7 +860,6 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) endif !Backward Euler method CS%var(m)%p(i,j,1:CS%nz) = I1pdamp * (CS%var(m)%p(i,j,1:CS%nz) + tmp_val1 * damp) - enddo enddo @@ -958,13 +871,11 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) !enddo if (CS%sponge_uv) then - ! u points do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB; do k=1,nz hu(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) enddo ; enddo ; enddo - - if (CS%new_sponges) then + if (CS%time_varying_sponges) then if (.not. present(Time)) & call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") @@ -974,10 +885,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Interpolate from the external horizontal grid and in time call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) - ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) - do c=1,CS%num_col ! c is an index for the next 3 lines but a multiplier for the rest of the loop ! Therefore we use c as per C code and increment the index where necessary. @@ -1014,9 +923,9 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) i = CS%col_i_u(c) ; j = CS%col_j_u(c) damp = dt*CS%Iresttime_col_u(c) I1pdamp = 1.0 / (1.0 + damp) - if (CS%new_sponges) nz_data = CS%Ref_val(m)%nz_data + if (CS%time_varying_sponges) nz_data = CS%Ref_val(m)%nz_data tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) - if (CS%new_sponges) then + if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%h(:,c), tmp_val2, & CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else @@ -1037,7 +946,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) damp = dt*CS%Iresttime_col_v(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) - if (CS%new_sponges) then + if (CS%time_varying_sponges) then call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_val_v%h(:,c), tmp_val2, & CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else From 251b0d91cb451c9ccc745b23f97aa0b4cddde644 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 29 Oct 2019 14:57:32 -0400 Subject: [PATCH 191/259] remove trailiny ws --- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 89229c642d..e29515fd8d 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -10,6 +10,7 @@ module MOM_ALE_sponge + ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field @@ -390,7 +391,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme - + if (associated(CS)) then call MOM_error(WARNING, "initialize_sponge called with an associated "// & "control structure.") @@ -574,7 +575,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< Grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). @@ -596,7 +597,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, type(remapping_CS) :: remapCS ! Remapping parameters and work arrays if (.not.associated(CS)) return - ! initialize time interpolator module + ! initialize time interpolator module call time_interp_external_init() isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed CS%fldno = CS%fldno + 1 @@ -774,7 +775,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. ! Local variables for ALE remapping - real, dimension(:), allocatable :: tmpT1d + real, dimension(:), allocatable :: tmpT1d integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data integer :: col, total_sponge_cols real, allocatable, dimension(:), target :: z_in, z_edges_in @@ -782,7 +783,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: h_neglect, h_neglect_edge real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. integer :: nPoints - + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(CS)) return From 241f3baa83ec98ceaf879ea6e543434e2ff42ef9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 16:36:55 -0400 Subject: [PATCH 192/259] Renamed internal vars dt to dt_in_s in MOM_dynamics Renamed internal variables dt to dt_in_s and dt_in_T to dt in the MOM_dynamics_... files in preparation for passing in timesteps in units of [T]. --- src/core/MOM_dynamics_split_RK2.F90 | 58 +++++++++++++------------- src/core/MOM_dynamics_unsplit.F90 | 60 +++++++++++++-------------- src/core/MOM_dynamics_unsplit_RK2.F90 | 40 +++++++++--------- 3 files changed, 79 insertions(+), 79 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index e2cdfd22c7..bbda47925b 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -233,7 +233,7 @@ module MOM_dynamics_split_RK2 !> RK2 splitting for time stepping MOM adiabatic dynamics subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & - Time_local, dt, forces, p_surf_begin, p_surf_end, & + Time_local, dt_in_s, forces, p_surf_begin, p_surf_end, & uh, vh, uhtr, vhtr, eta_av, & G, GV, US, CS, calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure @@ -248,7 +248,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic type type(vertvisc_type), intent(inout) :: visc !< vertical visc, bottom drag, and related type(time_type), intent(in) :: Time_local !< model time at end of time step - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt_in_s !< time step [s] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at start of this dynamic !! time step [Pa] @@ -317,7 +317,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. - real :: dt_in_T ! The dynamics time step [T ~> s] + real :: dt ! The dynamics time step [T ~> s] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -333,7 +333,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta - dt_in_T = US%s_to_T*dt + dt = US%s_to_T*dt_in_s sym=.false.;if (G%Domain%symmetric) sym=.true. ! switch to include symmetric domain in checksums @@ -408,7 +408,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! PFu = d/dx M(h,T,S) ! pbce = dM/deta - if (CS%begw == 0.0) call enable_averaging(dt, Time_local, CS%diag) + if (CS%begw == 0.0) call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_pres) call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) @@ -470,23 +470,23 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_in_T * u_bc_accel(I,j,k)) + up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * u_bc_accel(I,j,k)) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_in_T * v_bc_accel(i,J,k)) + vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * v_bc_accel(i,J,k)) enddo ; enddo enddo - call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, & + call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) if (CS%debug) then call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym) endif - call vertvisc_coef(up, vp, h, forces, visc, dt_in_T, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_in_T, G, GV, US, CS%vertvisc_CSp) + call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") @@ -514,7 +514,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! u_accel_bt = layer accelerations due to barotropic solver if (associated(CS%BT_cont) .or. CS%BT_use_layer_fluxes) then call cpu_clock_begin(id_clock_continuity) - call continuity(u, v, h, hp, uh_in, vh_in, dt_in_T, G, GV, US, CS%continuity_CSp, & + call continuity(u, v, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, & OBC=CS%OBC, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) if (BT_cont_BT_thick) then @@ -532,7 +532,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (calc_dtbt) call set_dtbt(G, GV, US, CS%barotropic_CSp, eta, CS%pbce) if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the predictor step call to btstep. - call btstep(u, v, eta, dt_in_T, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & + call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, & G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & OBC=CS%OBC, BT_cont=CS%BT_cont, eta_PF_start=eta_PF_start, & @@ -542,7 +542,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call cpu_clock_end(id_clock_btstep) ! up = u + dt_pred*( u_bc_accel + u_accel_bt ) - dt_pred = dt_in_T * CS%be + dt_pred = dt * CS%be call cpu_clock_begin(id_clock_mom_update) !$OMP parallel do default(shared) @@ -601,7 +601,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! uh = u_av * h ! hp = h + dt * div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(up, vp, h, hp, uh, vh, dt_in_T, G, GV, US, CS%continuity_CSp, & + call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, & CS%uhbt, CS%vhbt, CS%OBC, CS%visc_rem_u, CS%visc_rem_v, & u_av, v_av, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) @@ -634,7 +634,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & enddo ; enddo ; enddo ! The correction phase of the time step starts here. - call enable_averaging(dt, Time_local, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) ! Calculate a revised estimate of the free-surface height correction to be ! used in the next call to btstep. This call is at this point so that @@ -732,7 +732,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the corrector step call to btstep. - call btstep(u, v, eta, dt_in_T, u_bc_accel, v_bc_accel, forces, CS%pbce, & + call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, & CS%eta_PF, u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, & eta_pred, CS%uhbt, CS%vhbt, G, GV, US, CS%barotropic_CSp, & CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, OBC=CS%OBC, & @@ -753,11 +753,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_in_T * & + u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * & (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_in_T * & + v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * & (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) enddo ; enddo enddo @@ -777,15 +777,15 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u, v, h, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_in_T, G, GV, US, CS%vertvisc_CSp) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") @@ -806,7 +806,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! h = h + dt * div . uh ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. call cpu_clock_begin(id_clock_continuity) - call continuity(u, v, h, h, uh, vh, dt_in_T, G, GV, US, CS%continuity_CSp, & + call continuity(u, v, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, & CS%uhbt, CS%vhbt, CS%OBC, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) call cpu_clock_end(id_clock_continuity) call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) @@ -822,7 +822,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then - call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, US, dt) + call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, US, US%T_to_s*dt) endif ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. @@ -837,10 +837,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & !$OMP parallel do default(shared) do k=1,nz do j=js-2,je+2 ; do I=Isq-2,Ieq+2 - uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k)*dt_in_T + uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k)*dt enddo ; enddo do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 - vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k)*dt_in_T + vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k)*dt enddo ; enddo enddo @@ -954,7 +954,7 @@ end subroutine register_restarts_dyn_split_RK2 !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & - diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + diag, CS, restart_CS, dt_in_s, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & visc, dirs, ntrunc, calc_dtbt) @@ -976,7 +976,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure type(MOM_restart_CS), pointer :: restart_CS !< restart control structure - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt_in_s !< time step [s] type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for !! budget analysis type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation @@ -1178,7 +1178,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(uh,"uh",restart_CS) .or. & .not. query_initialized(vh,"vh",restart_CS)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo - call continuity(u, v, h, h_tmp, uh, vh, US%s_to_T*dt, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) + call continuity(u, v, h, h_tmp, uh, vh, US%s_to_T*dt_in_s, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) do k=1,nz ; do j=jsd,jed ; do i=isd,ied CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 6d91333852..c0725de4df 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -182,7 +182,7 @@ module MOM_dynamics_unsplit !> Step the MOM6 dynamics using an unsplit mixed 2nd order (for continuity) and !! 3rd order (for the inviscid momentum equations) order scheme -subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & +subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt_in_s, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & VarMix, MEKE, Waves) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -197,7 +197,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & !! viscosities, bottom drag viscosities, and related fields. type(time_type), intent(in) :: Time_local !< The model time at the end !! of the time step. - real, intent(in) :: dt !< The dynamics time step [s]. + real, intent(in) :: dt_in_s !< The dynamics time step [s]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface !! pressure at the start of this dynamic step [Pa]. @@ -227,14 +227,14 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up, upp ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() - real :: dt_in_T ! The dynamics time step [T ~> s] + real :: dt ! The dynamics time step [T ~> s] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz 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 - dt_in_T = US%s_to_T*dt - dt_pred = dt_in_T / 3.0 + dt = US%s_to_T*dt_in_s + dt_pred = dt / 3.0 h_av(:,:,:) = 0; hp(:,:,:) = 0 up(:,:,:) = 0; upp(:,:,:) = 0 @@ -255,7 +255,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & endif ! diffu = horizontal viscosity terms (u,h) - call enable_averaging(dt,Time_local, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, & G, GV, US, CS%hor_visc_CSp) @@ -265,12 +265,12 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! uh = u*h ! hp = h + dt/2 div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(u, v, h, hp, uh, vh, dt_in_T*0.5, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) + call continuity(u, v, h, hp, uh, vh, dt*0.5, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) - call enable_averaging(0.5*dt,Time_local-real_to_time(0.5*dt), CS%diag) + call enable_averaging(0.5*US%T_to_s*dt, Time_local-real_to_time(0.5*US%T_to_s*dt), CS%diag) ! Here the first half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) @@ -284,16 +284,16 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & h_av(i,j,k) = (h(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo do j=js,je ; do I=Isq,Ieq - u(I,j,k) = u(I,j,k) + dt_in_T * CS%diffu(I,j,k) * G%mask2dCu(I,j) + u(I,j,k) = u(I,j,k) + dt * CS%diffu(I,j,k) * G%mask2dCu(I,j) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - v(i,J,k) = v(i,J,k) + dt_in_T * CS%diffv(i,J,k) * G%mask2dCv(i,J) + v(i,J,k) = v(i,J,k) + dt * CS%diffv(i,J,k) * G%mask2dCv(i,J) enddo ; enddo do j=js-2,je+2 ; do I=Isq-2,Ieq+2 - uhtr(i,j,k) = uhtr(i,j,k) + 0.5*dt_in_T*uh(i,j,k) + uhtr(i,j,k) = uhtr(i,j,k) + 0.5*dt*uh(i,j,k) enddo ; enddo do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 - vhtr(i,j,k) = vhtr(i,j,k) + 0.5*dt_in_T*vh(i,j,k) + vhtr(i,j,k) = vhtr(i,j,k) + 0.5*dt*vh(i,j,k) enddo ; enddo enddo call cpu_clock_end(id_clock_mom_update) @@ -342,14 +342,14 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! up <- up + dt/2 d/dz visc d/dz up call cpu_clock_begin(id_clock_vertvisc) - call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h_av, tv, forces, visc, dt_in_T*0.5, G, GV, US, & + call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call set_viscous_ML(u, v, h_av, tv, forces, visc, dt*0.5, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) !### I think that the time steps in the next two calls should be dt_pred. - call vertvisc_coef(up, vp, h_av, forces, visc, dt_in_T*0.5, G, GV, US, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt*0.5, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h_av, forces, visc, dt_in_T*0.5, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc(up, vp, h_av, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -357,7 +357,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! uh = up * hp ! h_av = hp + dt/2 div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(up, vp, hp, h_av, uh, vh, (0.5*dt_in_T), G, GV, US, & + call continuity(up, vp, hp, h_av, uh, vh, (0.5*dt), G, GV, US, & CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(h_av, G%Domain, clock=id_clock_pass) @@ -394,11 +394,11 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp = u + dt/2 * ( PFu + CAu ) call cpu_clock_begin(id_clock_mom_update) do k=1,nz ; do j=js,je ; do I=Isq,Ieq - upp(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_in_T * 0.5 * & + upp(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * 0.5 * & (CS%PFu(I,j,k) + CS%CAu(I,j,k))) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - vpp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_in_T * 0.5 * & + vpp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * 0.5 * & (CS%PFv(i,J,k) + CS%CAv(i,J,k))) enddo ; enddo ; enddo call cpu_clock_end(id_clock_mom_update) @@ -411,9 +411,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt_in_T*0.5, G, GV, US, & + call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(upp, vpp, hp, forces, visc, dt_in_T*0.5, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(upp, vpp, G%Domain, clock=id_clock_pass) @@ -421,7 +421,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! uh = upp * hp ! h = hp + dt/2 div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(upp, vpp, hp, h, uh, vh, (dt_in_T*0.5), G, GV, US, & + call continuity(upp, vpp, hp, h, uh, vh, (dt*0.5), G, GV, US, & CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(h, G%Domain, clock=id_clock_pass) @@ -430,12 +430,12 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! for vertical remapping may need to be regenerated. call diag_update_remap_grids(CS%diag) - call enable_averaging(0.5*dt, Time_local, CS%diag) + call enable_averaging(0.5*US%T_to_s*dt, Time_local, CS%diag) ! Here the second half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) call disable_averaging(CS%diag) - call enable_averaging(dt, Time_local, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) ! h_av = (h + hp)/2 do k=1,nz @@ -443,10 +443,10 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo do j=js-2,je+2 ; do I=Isq-2,Ieq+2 - uhtr(i,j,k) = uhtr(i,j,k) + 0.5*dt_in_T*uh(i,j,k) + uhtr(i,j,k) = uhtr(i,j,k) + 0.5*dt*uh(i,j,k) enddo ; enddo do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 - vhtr(i,j,k) = vhtr(i,j,k) + 0.5*dt_in_T*vh(i,j,k) + vhtr(i,j,k) = vhtr(i,j,k) + 0.5*dt*vh(i,j,k) enddo ; enddo enddo @@ -472,18 +472,18 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) endif do k=1,nz ; do j=js,je ; do I=Isq,Ieq - u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_in_T * & + u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * & (CS%PFu(I,j,k) + CS%CAu(I,j,k))) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_in_T * & + v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * & (CS%PFv(i,J,k) + CS%CAv(i,J,k))) enddo ; enddo ; enddo ! u <- u + dt d/dz visc d/dz u call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h_av, forces, visc, dt_in_T, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u, v, h_av, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(u, v, G%Domain, clock=id_clock_pass) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 955ddf57e9..6adb6469a7 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -185,7 +185,7 @@ module MOM_dynamics_unsplit_RK2 ! ============================================================================= !> Step the MOM6 dynamics using an unsplit quasi-2nd order Runge-Kutta scheme -subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, forces, & +subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt_in_s, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & VarMix, MEKE) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -205,7 +205,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, !! viscosities, and related fields. type(time_type), intent(in) :: Time_local !< The model time at the end of !! the time step. - real, intent(in) :: dt !< The baroclinic dynamics time step [s]. + real, intent(in) :: dt_in_s !< The baroclinic dynamics time step [s]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to !! the surface pressure at the beginning @@ -238,15 +238,15 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() - real :: dt_in_T ! The dynamics time step [T ~> s] + real :: dt ! The dynamics time step [T ~> s] real :: dt_pred ! The time step for the predictor part of the baroclinic ! time stepping [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz 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 - dt_in_T = US%s_to_T*dt - dt_pred = dt_in_T * CS%BE + dt = US%s_to_T*dt_in_s + dt_pred = dt * CS%BE h_av(:,:,:) = 0; hp(:,:,:) = 0 up(:,:,:) = 0 @@ -267,7 +267,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, endif ! diffu = horizontal viscosity terms (u,h) - call enable_averaging(dt,Time_local, CS%diag) + call enable_averaging(US%T_to_s*dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & G, GV, US, CS%hor_visc_CSp) @@ -340,7 +340,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) - call enable_averaging(dt, Time_local, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_pred, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) @@ -354,7 +354,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! uh = up[n-1/2] * h[n-1/2] ! h_av = h + dt div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(up, vp, h_in, hp, uh, vh, dt_in_T, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) + call continuity(up, vp, h_in, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) @@ -376,33 +376,33 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) endif -! call enable_averaging(dt,Time_local, CS%diag) ?????????????????????/ +! call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) ?????????????????????/ ! up* = u[n] + (1+gamma) * dt * ( PFu + CAu ) Extrapolated for damping ! u*[n+1] = u[n] + dt * ( PFu + CAu ) do k=1,nz ; do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u_in(I,j,k) + dt_in_T * (1.+CS%begw) * & + up(I,j,k) = G%mask2dCu(I,j) * (u_in(I,j,k) + dt * (1.+CS%begw) * & ((CS%PFu(I,j,k) + CS%CAu(I,j,k)) + CS%diffu(I,j,k))) - u_in(I,j,k) = G%mask2dCu(I,j) * (u_in(I,j,k) + dt_in_T * & + u_in(I,j,k) = G%mask2dCu(I,j) * (u_in(I,j,k) + dt * & ((CS%PFu(I,j,k) + CS%CAu(I,j,k)) + CS%diffu(I,j,k))) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v_in(i,J,k) + dt_in_T * (1.+CS%begw) * & + vp(i,J,k) = G%mask2dCv(i,J) * (v_in(i,J,k) + dt * (1.+CS%begw) * & ((CS%PFv(i,J,k) + CS%CAv(i,J,k)) + CS%diffv(i,J,k))) - v_in(i,J,k) = G%mask2dCv(i,J) * (v_in(i,J,k) + dt_in_T * & + v_in(i,J,k) = G%mask2dCv(i,J) * (v_in(i,J,k) + dt * & ((CS%PFv(i,J,k) + CS%CAv(i,J,k)) + CS%diffv(i,J,k))) enddo ; enddo ; enddo ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_in_T, G, GV, US, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h_av, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp, & + call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt_in_T, G, GV, US, & + call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, & CS%vertvisc_CSp, CS%OBC) - call vertvisc(u_in, v_in, h_av, forces, visc, dt_in_T, CS%OBC, CS%ADp, CS%CDp,& + call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -411,7 +411,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! uh = up[n] * h[n] (up[n] might be extrapolated to damp GWs) ! h[n+1] = h[n] + dt div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(up, vp, h_in, h_in, uh, vh, dt_in_T, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) + call continuity(up, vp, h_in, h_in, uh, vh, dt, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(h_in, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) @@ -419,10 +419,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! Accumulate mass flux for tracer transport do k=1,nz do j=js-2,je+2 ; do I=Isq-2,Ieq+2 - uhtr(I,j,k) = uhtr(I,j,k) + dt_in_T*uh(I,j,k) + uhtr(I,j,k) = uhtr(I,j,k) + dt*uh(I,j,k) enddo ; enddo do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 - vhtr(i,J,k) = vhtr(i,J,k) + dt_in_T*vh(i,J,k) + vhtr(i,J,k) = vhtr(i,J,k) + dt*vh(i,J,k) enddo ; enddo enddo From 0be3f0ee82f7b540daf2c4f0ea28eacbb73a3a39 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 16:38:24 -0400 Subject: [PATCH 193/259] +Pass timesteps to sponge code in [T] Pass timesteps to apply_ALE_sponge, apply_sponge, geothermal and regularize_layers in units of [T], and also store the sponge restoring rates internally in units of T-1. This required passing new vertcalGrid_type and unit_scale_type arguments to init_sponge_diags. Also renamed internal variables dt to dt_in_s and dt_in_T to dt in MOM_diabatic_driver.F90 and rescaled the units of the vertical advective and diffusive heat and salt fluxes. All answers are bitwise identical, but public interfaces have changed. --- src/core/MOM.F90 | 2 +- .../vertical/MOM_ALE_sponge.F90 | 27 +- .../vertical/MOM_diabatic_driver.F90 | 278 +++++++++--------- .../vertical/MOM_geothermal.F90 | 17 +- .../vertical/MOM_regularize_layers.F90 | 4 +- src/parameterizations/vertical/MOM_sponge.F90 | 24 +- 6 files changed, 176 insertions(+), 176 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 69835d6dcf..0895ad6da8 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2348,7 +2348,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call diag_copy_diag_to_storage(CS%diag_pre_sync, CS%h, CS%diag) if (associated(CS%sponge_CSp)) & - call init_sponge_diags(Time, G, diag, CS%sponge_CSp) + call init_sponge_diags(Time, G, GV, US, diag, CS%sponge_CSp) if (associated(CS%ALE_sponge_CSp)) & call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 17b601427c..dd58368bd3 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -110,9 +110,9 @@ module MOM_ALE_sponge integer, pointer :: col_i_v(:) => NULL() !< Array of the i-indicies of each v-columns being damped. integer, pointer :: col_j_v(:) => NULL() !< Array of the j-indicies of each v-columns being damped. - real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each tracer column [s-1]. - real, pointer :: Iresttime_col_u(:) => NULL() !< The inverse restoring time of each u-column [s-1]. - real, pointer :: Iresttime_col_v(:) => NULL() !< The inverse restoring time of each v-column [s-1]. + real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each tracer column [T-1 ~> s-1]. + real, pointer :: Iresttime_col_u(:) => NULL() !< The inverse restoring time of each u-column [T-1 ~> s-1]. + real, pointer :: Iresttime_col_v(:) => NULL() !< The inverse restoring time of each v-column [T-1 ~> s-1]. type(p3d) :: var(MAX_FIELDS_) !< Pointers to the fields that are being damped. type(p2d) :: Ref_val(MAX_FIELDS_) !< The values to which the fields are damped. @@ -217,7 +217,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then CS%col_i(col) = i ; CS%col_j(col) = j - CS%Iresttime_col(col) = Iresttime(i,j) + CS%Iresttime_col(col) = G%US%T_to_s*Iresttime(i,j) col = col +1 endif enddo ; enddo @@ -265,7 +265,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then CS%col_i_u(col) = i ; CS%col_j_u(col) = j - CS%Iresttime_col_u(col) = Iresttime_u(i,j) + CS%Iresttime_col_u(col) = G%US%T_to_s*Iresttime_u(i,j) col = col +1 endif enddo ; enddo @@ -302,7 +302,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j - CS%Iresttime_col_v(col) = Iresttime_v(i,j) + CS%Iresttime_col_v(col) = G%US%T_to_s*Iresttime_v(i,j) col = col +1 endif enddo ; enddo @@ -455,7 +455,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then CS%col_i(col) = i ; CS%col_j(col) = j - CS%Iresttime_col(col) = Iresttime(i,j) + CS%Iresttime_col(col) = G%US%T_to_s*Iresttime(i,j) col = col +1 endif enddo ; enddo @@ -494,7 +494,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then CS%col_i_u(col) = i ; CS%col_j_u(col) = j - CS%Iresttime_col_u(col) = Iresttime_u(i,j) + CS%Iresttime_col_u(col) = G%US%T_to_s*Iresttime_u(i,j) col = col +1 endif enddo ; enddo @@ -526,7 +526,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j - CS%Iresttime_col_v(col) = Iresttime_v(i,j) + CS%Iresttime_col_v(col) = G%US%T_to_s*Iresttime_v(i,j) col = col +1 endif enddo ; enddo @@ -859,14 +859,13 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) - real, intent(in) :: dt !< The amount of time covered by this call [s]. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_sponge (in). type(time_type), optional, intent(in) :: Time !< The current model date real :: damp ! The timestep times the local damping coefficient [nondim]. real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. - real :: Idt ! 1.0/dt [s-1]. real :: m_to_Z ! A unit conversion factor from m to Z. real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid real, dimension(SZK_(G)) :: tmp_val1 ! data values remapped to model grid @@ -934,7 +933,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! c is an index for the next 3 lines but a multiplier for the rest of the loop ! Therefore we use c as per C code and increment the index where necessary. i = CS%col_i(c) ; j = CS%col_j(c) - damp = dt*CS%Iresttime_col(c) + damp = dt * CS%Iresttime_col(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) if (CS%new_sponges) then @@ -1012,7 +1011,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) do c=1,CS%num_col_u i = CS%col_i_u(c) ; j = CS%col_j_u(c) - damp = dt*CS%Iresttime_col_u(c) + damp = dt * CS%Iresttime_col_u(c) I1pdamp = 1.0 / (1.0 + damp) if (CS%new_sponges) nz_data = CS%Ref_val(m)%nz_data tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) @@ -1034,7 +1033,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) do c=1,CS%num_col_v i = CS%col_i_v(c) ; j = CS%col_j_v(c) - damp = dt*CS%Iresttime_col_v(c) + damp = dt * CS%Iresttime_col_v(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) if (CS%new_sponges) then diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 4d8025a1d9..4587949e30 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -254,7 +254,7 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt_in_s, Time_end, & G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -272,7 +272,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [s] + real, intent(in) :: dt_in_s !< time increment [s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves @@ -283,13 +283,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn_IGW ! baroclinic internal gravity wave speeds real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp - real :: dt_in_T ! The time step converted to T units [T ~> s] + real :: dt ! The time step converted to T units [T ~> s] integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree if (G%ke == 1) return - 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 + dt = dt_in_s * US%s_to_T if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "Module must be initialized before it is used.") @@ -312,7 +313,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call post_data(CS%id_e_predia, eta, CS%diag) endif - dt_in_T = dt * US%s_to_T if (CS%debug) then call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("Start of diabatic", fluxes, G, US, haloshift=0) @@ -320,7 +320,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%debugConservation) call MOM_state_stats('Start of diabatic', u, v, h, tv%T, tv%S, G, GV, US) if (CS%debug_energy_req) & - call diapyc_energy_req_test(h, dt_in_T, tv, G, GV, US, CS%diapyc_en_rec_CSp) + call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) call cpu_clock_begin(id_clock_set_diffusivity) call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp) @@ -331,7 +331,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*dt, Time_end - real_to_time(0.5*dt), CS%diag) + call enable_averaging(0.5*US%T_to_s*dt, Time_end - real_to_time(0.5*US%T_to_s*dt), CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) @@ -356,7 +356,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%use_int_tides) then ! This block provides an interface for the unresolved low-mode internal tide module (BDM). - call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt_in_T, G, GV, US, & + call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & CS%int_tide_input_CSp) cn_IGW(:,:,:) = 0.0 if (CS%uniform_test_cg > 0.0) then @@ -366,7 +366,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif call propagate_int_tide(h, tv, cn_IGW, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, dt_in_T, G, GV, US, CS%int_tide_CSp) + CS%int_tide_input%Nb, dt, G, GV, US, CS%int_tide_CSp) if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides @@ -392,7 +392,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! make_frazil is deliberately called at both the beginning and at ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then - call enable_averaging(0.5*dt, Time_end, CS%diag) + call enable_averaging(0.5*US%T_to_s*dt, Time_end, CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) @@ -418,7 +418,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! Diagnose mixed layer depths. - call enable_averaging(dt, Time_end, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) @@ -461,7 +461,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [s] + real, intent(in) :: dt !< time increment [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves @@ -507,10 +507,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] - Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] - Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, ! where massive is defined as sufficiently thick that @@ -538,7 +538,6 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] real :: Idt ! The inverse time step [s-1] - real :: dt_in_T ! The time step converted to T units [T ~> s] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree @@ -557,10 +556,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (showCallTree) call callTree_enter("diabatic_ALE_legacy(), MOM_diabatic_driver.F90") ! if (showCallTree) call callTree_enter("diabatic_ALE(), MOM_diabatic_driver.F90") - dt_in_T = dt * US%s_to_T - ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep - call enable_averaging(dt, Time_end, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) if (CS%use_geothermal) then halo = CS%halo_TS_diff @@ -607,7 +604,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S and visc%TKE_turb ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & - visc, dt_in_T, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) + visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") @@ -718,8 +715,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, dt, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, dt, tv%S) + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + US%T_to_s*dt, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + US%T_to_s*dt, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) @@ -737,7 +736,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim (CS%use_legacy_diabatic .or. .not.CS%use_CVMix_ddiff)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv, visc, dt_in_T, G, GV) + call differential_diffuse_T_S(h, tv, visc, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") @@ -787,7 +786,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(hval) do k=2,nz ; do j=js,je ; do i=is,ie hval=1.0/(h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ea_s(i,j,k) = (GV%Z_to_H**2) * dt_in_T * hval * Kd_int(i,j,K) + ea_s(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_int(i,j,K) eb_s(i,j,k-1) = ea_s(i,j,k) ea_t(i,j,k-1) = ea_s(i,j,k-1) ; eb_t(i,j,k-1) = eb_s(i,j,k-1) enddo ; enddo ; enddo @@ -825,7 +824,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%use_energetic_PBL) then skinbuoyflux(:,:) = 0.0 - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) @@ -841,7 +840,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt_in_T, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -866,7 +865,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%use_legacy_diabatic) then - Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt_in_T) / & + Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt) / & (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) eb_s(i,j,k-1) = eb_s(i,j,k-1) + Ent_int ea_s(i,j,k) = ea_s(i,j,k) + Ent_int @@ -891,7 +890,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif else - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & CS%evap_CFL_limit, CS%minimum_forcing_depth) @@ -984,8 +983,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ea_t(i,j,k) = ea_s(i,j,k) ; eb_t(i,j,k) = eb_s(i,j,k) enddo ; enddo ; enddo if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea_t, eb_t, dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea_s, eb_s, dt, tv%S, G, GV) + call tracer_vertdiff(hold, ea_t, eb_t, US%T_to_s*dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea_s, eb_s, US%T_to_s*dt, tv%S, G, GV) else call triDiagTS(G, GV, is, ie, js, je, hold, ea_s, eb_s, tv%T, tv%S) endif @@ -1008,9 +1007,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(hval) do k=2,nz ; do j=js,je ; do i=is,ie hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ea_t(i,j,k) = (GV%Z_to_H**2) * dt_in_T * hval * Kd_heat(i,j,k) + ea_t(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_heat(i,j,k) eb_t(i,j,k-1) = ea_t(i,j,k) - ea_s(i,j,k) = (GV%Z_to_H**2) * dt_in_T * hval * Kd_salt(i,j,k) + ea_s(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_salt(i,j,k) eb_s(i,j,k-1) = ea_s(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -1020,8 +1019,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim "and Kd_salt (diabatic)") ! Changes T and S via the tridiagonal solver; no change to h - call tracer_vertdiff(h, ea_t, eb_t, dt, tv%T, G, GV) - call tracer_vertdiff(h, ea_s, eb_s, dt, tv%S, G, GV) + call tracer_vertdiff(h, ea_t, eb_t, US%T_to_s*dt, tv%T, G, GV) + call tracer_vertdiff(h, ea_s, eb_s, US%T_to_s*dt, tv%S, G, GV) ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below if (CS%diabatic_diff_tendency_diag) & @@ -1081,7 +1080,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracers) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt_in_T*CS%Kd_BBL_tr) + Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1100,7 +1099,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_int, ! perhaps a molecular diffusivity. - add_ent = ((dt_in_T * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ea_s(i,j,k) + eb_s(i,j,k-1)) @@ -1119,10 +1118,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then if (CS%use_legacy_diabatic) then - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + h_neglect) else - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + & h_neglect) endif @@ -1136,7 +1135,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied ! so hold should be h_orig - call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -1150,10 +1149,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (visc%Kd_extra_S(i,j,k) > 0.0) then if (CS%use_legacy_diabatic) then - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + h_neglect) else - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + & h_neglect) endif @@ -1165,13 +1164,13 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim enddo ; enddo ; enddo ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -1195,7 +1194,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call disable_averaging(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - call enable_averaging(dt, Time_end, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) @@ -1245,7 +1244,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [s] + real, intent(in) :: dt !< time increment [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves @@ -1291,10 +1290,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] - Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] - Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, ! where massive is defined as sufficiently thick that @@ -1322,7 +1321,6 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] real :: Idt ! The inverse time step [s-1] - real :: dt_in_T ! The time step converted to T units [T ~> s] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree @@ -1343,10 +1341,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (.not. (CS%useALEalgorithm)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "The ALE algorithm must be enabled when using MOM_diabatic_driver.") - dt_in_T = dt * US%s_to_T - ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep - call enable_averaging(dt, Time_end, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) if (CS%use_geothermal) then halo = CS%halo_TS_diff @@ -1393,7 +1389,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S and visc%TKE_turb ! Also changes: visc%Kd_shear, visc%Kv_shear and visc%Kv_slow call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & - visc, dt_in_T, G, GV, US,CS%set_diff_CSp, Kd_lay, Kd_int) + visc, dt, G, GV, US,CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") @@ -1484,8 +1480,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, dt, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, dt, tv%S) + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + US%T_to_s*dt, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + US%T_to_s*dt, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) @@ -1503,7 +1501,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, (.not.CS%use_CVMix_ddiff)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv, visc, dt_in_T, G, GV) + call differential_diffuse_T_S(h, tv, visc, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") @@ -1556,7 +1554,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%use_energetic_PBL) then skinbuoyflux(:,:) = 0.0 - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) @@ -1572,7 +1570,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt_in_T, Kd_ePBL, G, GV, US, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then @@ -1610,7 +1608,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif else - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt_in_T, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & CS%evap_CFL_limit, CS%minimum_forcing_depth) @@ -1674,9 +1672,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, !$OMP parallel do default(shared) private(hval) do k=2,nz ; do j=js,je ; do i=is,ie hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ea_t(i,j,k) = (GV%Z_to_H**2) * dt_in_T * hval * Kd_heat(i,j,k) + ea_t(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_heat(i,j,k) eb_t(i,j,k-1) = ea_t(i,j,k) - ea_s(i,j,k) = (GV%Z_to_H**2) * dt_in_T * hval * Kd_salt(i,j,k) + ea_s(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_salt(i,j,k) eb_s(i,j,k-1) = ea_s(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -1703,8 +1701,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ! Changes T and S via the tridiagonal solver; no change to h - call tracer_vertdiff(h, ea_t, eb_t, dt, tv%T, G, GV) - call tracer_vertdiff(h, ea_s, eb_s, dt, tv%S, G, GV) + call tracer_vertdiff(h, ea_t, eb_t, US%T_to_s*dt, tv%T, G, GV) + call tracer_vertdiff(h, ea_s, eb_s, US%T_to_s*dt, tv%S, G, GV) ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below @@ -1761,7 +1759,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracers) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt_in_T*CS%Kd_BBL_tr) + Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1780,7 +1778,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_int, ! perhaps a molecular diffusivity. - add_ent = ((dt_in_T * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ea_s(i,j,k) + eb_s(i,j,k-1)) @@ -1798,7 +1796,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + & h_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent @@ -1811,7 +1809,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied ! so hold should be h_orig - call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -1824,7 +1822,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + & h_neglect) else @@ -1835,13 +1833,13 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -1879,7 +1877,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call disable_averaging(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - call enable_averaging(dt, Time_end, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) @@ -1925,7 +1923,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment [s] + real, intent(in) :: dt !< time increment [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves @@ -1966,10 +1964,10 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] - Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] - Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] ! The following 5 variables are only used with a bulk mixed layer. real, pointer, dimension(:,:,:) :: & @@ -2013,7 +2011,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real :: dt_mix ! The amount of time over which to apply mixing [T ~> s] real :: Idt ! The inverse time step [s-1] real :: Idt_accel ! The inverse time step times rescaling factors [T-1 ~> s-1] - real :: dt_in_T ! The time step converted to T units [T ~> s] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree @@ -2034,10 +2031,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! set equivalence between the same bits of memory for these arrays eaml => eatr ; ebml => ebtr - dt_in_T = dt * US%s_to_T ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep - call enable_averaging(dt, Time_end, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then halo = CS%halo_TS_diff @@ -2081,17 +2077,17 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call cpu_clock_begin(id_clock_mixedlayer) if (CS%ML_mix_first < 1.0) then ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) - call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_in_T*CS%ML_mix_first, & + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & eaml,ebml, G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt_in_T, last_call=.false.) + Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) if (CS%salt_reject_below_ML) & call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, & - dt_in_T*CS%ML_mix_first, CS%id_brine_lay) + dt*CS%ML_mix_first, CS%id_brine_lay) else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) - call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_in_T, eaml, ebml, & + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt_in_T, last_call=.true.) + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) endif ! Keep salinity from falling below a small but positive threshold. @@ -2136,7 +2132,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) endif call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, & - visc, dt_in_T, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) + visc, dt, G, GV, US, CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") @@ -2245,8 +2241,10 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, dt, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, dt, tv%S) + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + US%T_to_s*dt, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + US%T_to_s*dt, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) @@ -2263,7 +2261,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv, visc, dt_in_T, G, GV) + call differential_diffuse_T_S(h, tv, visc, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G, GV, US) @@ -2288,7 +2286,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call cpu_clock_begin(id_clock_entrain) ! Calculate appropriately limited diapycnal mass fluxes to account ! for diapycnal diffusion and advection. Sets: ea, eb. Changes: kb - call Entrainment_diffusive(h, tv, fluxes, dt_in_T, G, GV, US, CS%entrain_diffusive_CSp, & + call Entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS%entrain_diffusive_CSp, & ea, eb, kb, Kd_lay=Kd_lay, Kd_int=Kd_int) call cpu_clock_end(id_clock_entrain) if (showCallTree) call callTree_waypoint("done with Entrainment_diffusive (diabatic)") @@ -2433,8 +2431,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! between the buffer layers and the interior. ! Changes: T, S if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) + call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%S, G, GV) else call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) endif @@ -2471,12 +2469,12 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call find_uv_at_h(u, v, hold, u_h, v_h, G, GV, US, ea, eb) if (CS%debug) call MOM_state_chksum("find_uv_at_h1 ", u, v, h, G, GV, US, haloshift=0) - dt_mix = min(dt_in_T, dt_in_T*(1.0 - CS%ML_mix_first)) + dt_mix = min(dt, dt*(1.0 - CS%ML_mix_first)) call cpu_clock_begin(id_clock_mixedlayer) ! Changes: h, tv%T, tv%S, ea and eb (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_mix, ea, eb, & G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt_in_T, last_call=.true.) + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) if (CS%salt_reject_below_ML) & call insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS%diabatic_aux_CSp, dt_mix, & @@ -2525,8 +2523,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Changes T and S via the tridiagonal solver; no change to h if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) + call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%S, G, GV) else call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) endif @@ -2536,7 +2534,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! the bulk mixed layer scheme, so tendencies should be posted on hold. if (CS%diabatic_diff_tendency_diag) then call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) - if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h = hold) + if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h=hold) endif call cpu_clock_end(id_clock_tridiag) @@ -2599,7 +2597,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracers) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt_in_T*CS%Kd_BBL_tr) + Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -2618,7 +2616,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_lay, ! perhaps a molecular diffusivity. - add_ent = ((dt_in_T * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ea(i,j,k) + eb(i,j,k-1)) @@ -2635,7 +2633,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) endif if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent @@ -2646,7 +2644,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -2657,7 +2655,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt_in_T * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) else @@ -2667,11 +2665,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eatr(i,j,k) = ea(i,j,k) + add_ent enddo ; enddo ; enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) else - call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) endif ! (CS%mix_boundary_tracers) @@ -2705,7 +2703,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) do j=js,je do K=2,nz ; do i=is,ie - CDp%diapyc_vel(i,j,K) = Idt * (ea(i,j,k) - eb(i,j,k-1)) + CDp%diapyc_vel(i,j,K) = US%s_to_T*Idt * (ea(i,j,k) - eb(i,j,k-1)) enddo ; enddo do i=is,ie CDp%diapyc_vel(i,j,1) = 0.0 @@ -2768,7 +2766,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call hchksum(hold, "before u/v tridiag hold",G%HI, scale=GV%H_to_m) endif call cpu_clock_begin(id_clock_tridiag) - Idt_accel = 1.0 / dt_in_T + Idt_accel = 1.0 / dt !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) do j=js,je do I=Isq,Ieq @@ -2837,7 +2835,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call disable_averaging(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - call enable_averaging(dt, Time_end, CS%diag) + call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) @@ -2919,13 +2917,13 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to diabatic physics real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: saln_old !< salinity prior to diabatic physics [ppt] - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] type(diabatic_CS), pointer :: CS !< module control structure ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt ! The inverse of the timestep [s-1] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz logical :: do_saln_tend ! Calculate salinity-based tendency diagnosics @@ -2941,7 +2939,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo if (CS%id_diabatic_diff_temp_tend > 0) then - call post_data(CS%id_diabatic_diff_temp_tend, work_3d, CS%diag, alt_h = h) + call post_data(CS%id_diabatic_diff_temp_tend, work_3d, CS%diag, alt_h=h) endif ! heat tendency @@ -2950,7 +2948,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * tv%C_p * work_3d(i,j,k) enddo ; enddo ; enddo if (CS%id_diabatic_diff_heat_tend > 0) then - call post_data(CS%id_diabatic_diff_heat_tend, work_3d, CS%diag, alt_h = h) + call post_data(CS%id_diabatic_diff_heat_tend, work_3d, CS%diag, alt_h=h) endif if (CS%id_diabatic_diff_heat_tend_2d > 0) then do j=js,je ; do i=is,ie @@ -3016,13 +3014,13 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, intent(in) :: saln_old !< salinity prior to boundary flux application [ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h_old !< thickness prior to boundary flux application [H ~> m or kg m-2] - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] type(diabatic_CS), pointer :: CS !< module control structure ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt ! The inverse of the timestep [s-1] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz @@ -3036,7 +3034,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (h(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo - call post_data(CS%id_boundary_forcing_h_tendency, work_3d, CS%diag, alt_h = h_old) + call post_data(CS%id_boundary_forcing_h_tendency, work_3d, CS%diag, alt_h=h_old) endif ! temperature tendency @@ -3044,7 +3042,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo - call post_data(CS%id_boundary_forcing_temp_tend, work_3d, CS%diag, alt_h = h_old) + call post_data(CS%id_boundary_forcing_temp_tend, work_3d, CS%diag, alt_h=h_old) endif ! heat tendency @@ -3107,10 +3105,10 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to frazil formation [degC] - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -3407,16 +3405,16 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (use_temperature) then CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff",diag%axesTi, & Time, "Diffusive diapycnal temperature flux across interfaces", & - "degC m s-1", conversion=GV%H_to_m) + "degC m s-1", conversion=GV%H_to_m*US%s_to_T) CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv",diag%axesTi, & Time, "Advective diapycnal temperature flux across interfaces", & - "degC m s-1", conversion=GV%H_to_m) + "degC m s-1", conversion=GV%H_to_m*US%s_to_T) CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff",diag%axesTi, & Time, "Diffusive diapycnal salnity flux across interfaces", & - "psu m s-1", conversion=GV%H_to_m) + "psu m s-1", conversion=GV%H_to_m*US%s_to_T) CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv",diag%axesTi, & Time, "Advective diapycnal salnity flux across interfaces", & - "psu m s-1", conversion=GV%H_to_m) + "psu m s-1", conversion=GV%H_to_m*US%s_to_T) CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & 'Mixed layer depth (delta rho = 0.03)', 'm', conversion=US%Z_to_m, & cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & @@ -3517,12 +3515,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & - long_name = 'Cell thickness used during diabatic diffusion', units='m', & + long_name='Cell thickness used during diabatic diffusion', units='m', & conversion=GV%H_to_m, v_extensive=.true.) if (CS%useALEalgorithm) then CS%id_diabatic_diff_temp_tend = register_diag_field('ocean_model', & 'diabatic_diff_temp_tendency', diag%axesTL, Time, & - 'Diabatic diffusion temperature tendency', 'degC s-1') + 'Diabatic diffusion temperature tendency', 'degC s-1', conversion=US%s_to_T) if (CS%id_diabatic_diff_temp_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif @@ -3537,11 +3535,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & 'diabatic_heat_tendency', diag%axesTL, Time, & 'Diabatic diffusion heat tendency', & - 'W m-2',cmor_field_name='opottempdiff', & + 'W m-2', conversion=US%s_to_T, cmor_field_name='opottempdiff', & cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'// & 'due_to_parameterized_dianeutral_mixing', & cmor_long_name='Tendency of sea water potential temperature expressed as heat content '// & - 'due to parameterized dianeutral mixing',& + 'due to parameterized dianeutral mixing', & v_extensive=.true.) if (CS%id_diabatic_diff_heat_tend > 0) then CS%diabatic_diff_tendency_diag = .true. @@ -3550,7 +3548,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & 'diabatic_salt_tendency', diag%axesTL, Time, & 'Diabatic diffusion of salt tendency', & - 'kg m-2 s-1',cmor_field_name='osaltdiff', & + 'kg m-2 s-1', conversion=US%s_to_T, cmor_field_name='osaltdiff', & cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & 'due_to_parameterized_dianeutral_mixing', & cmor_long_name='Tendency of sea water salinity expressed as salt content '// & @@ -3564,7 +3562,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_heat_tend_2d = register_diag_field('ocean_model', & 'diabatic_heat_tendency_2d', diag%axesT1, Time, & 'Depth integrated diabatic diffusion heat tendency', & - 'W m-2',cmor_field_name='opottempdiff_2d', & + 'W m-2', conversion=US%s_to_T, cmor_field_name='opottempdiff_2d', & cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'//& 'due_to_parameterized_dianeutral_mixing_depth_integrated', & cmor_long_name='Tendency of sea water potential temperature expressed as heat content '//& @@ -3577,7 +3575,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & 'diabatic_salt_tendency_2d', diag%axesT1, Time, & 'Depth integrated diabatic diffusion salt tendency', & - 'kg m-2 s-1',cmor_field_name='osaltdiff_2d', & + 'kg m-2 s-1', conversion=US%s_to_T, cmor_field_name='osaltdiff_2d', & cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & 'due_to_parameterized_dianeutral_mixing_depth_integrated', & cmor_long_name='Tendency of sea water salinity expressed as salt content '// & @@ -3590,11 +3588,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & - long_name = 'Cell thickness after applying boundary forcing', units='m', & + long_name='Cell thickness after applying boundary forcing', units='m', & conversion=GV%H_to_m, v_extensive=.true.) CS%id_boundary_forcing_h_tendency = register_diag_field('ocean_model', & 'boundary_forcing_h_tendency', diag%axesTL, Time, & - 'Cell thickness tendency due to boundary forcing', 'm s-1', & + 'Cell thickness tendency due to boundary forcing', 'm s-1', conversion=US%s_to_T, & v_extensive = .true.) if (CS%id_boundary_forcing_h_tendency > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3602,21 +3600,21 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_temp_tend = register_diag_field('ocean_model',& 'boundary_forcing_temp_tendency', diag%axesTL, Time, & - 'Boundary forcing temperature tendency', 'degC s-1') + 'Boundary forcing temperature tendency', 'degC s-1', conversion=US%s_to_T) if (CS%id_boundary_forcing_temp_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif CS%id_boundary_forcing_saln_tend = register_diag_field('ocean_model',& 'boundary_forcing_saln_tendency', diag%axesTL, Time, & - 'Boundary forcing saln tendency', 'psu s-1') + 'Boundary forcing saln tendency', 'psu s-1', conversion=US%s_to_T) if (CS%id_boundary_forcing_saln_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif CS%id_boundary_forcing_heat_tend = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency', diag%axesTL, Time, & - 'Boundary forcing heat tendency','W m-2', & + 'Boundary forcing heat tendency', 'W m-2', conversion=US%s_to_T, & v_extensive = .true.) if (CS%id_boundary_forcing_heat_tend > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3624,7 +3622,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency', diag%axesTL, Time, & - 'Boundary forcing salt tendency','kg m-2 s-1', & + 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%s_to_T, & v_extensive = .true.) if (CS%id_boundary_forcing_salt_tend > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3633,7 +3631,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! This diagnostic should equal to surface heat flux if all is working well. CS%id_boundary_forcing_heat_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency_2d', diag%axesT1, Time, & - 'Depth integrated boundary forcing of ocean heat','W m-2') + 'Depth integrated boundary forcing of ocean heat', 'W m-2', conversion=US%s_to_T) if (CS%id_boundary_forcing_heat_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3649,13 +3647,13 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! diagnostics for tendencies of temp and heat due to frazil CS%id_frazil_h = register_diag_field('ocean_model', 'frazil_h', diag%axesTL, Time, & - long_name = 'Cell Thickness', standard_name='cell_thickness', units='m', & + long_name='Cell Thickness', standard_name='cell_thickness', units='m', & conversion=GV%H_to_m, v_extensive=.true.) ! diagnostic for tendency of temp due to frazil CS%id_frazil_temp_tend = register_diag_field('ocean_model',& 'frazil_temp_tendency', diag%axesTL, Time, & - 'Temperature tendency due to frazil formation', 'degC s-1') + 'Temperature tendency due to frazil formation', 'degC s-1', conversion=US%s_to_T) if (CS%id_frazil_temp_tend > 0) then CS%frazil_tendency_diag = .true. endif @@ -3663,7 +3661,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! diagnostic for tendency of heat due to frazil CS%id_frazil_heat_tend = register_diag_field('ocean_model',& 'frazil_heat_tendency', diag%axesTL, Time, & - 'Heat tendency due to frazil formation','W m-2', v_extensive = .true.) + 'Heat tendency due to frazil formation', 'W m-2', conversion=US%s_to_T, v_extensive=.true.) if (CS%id_frazil_heat_tend > 0) then CS%frazil_tendency_diag = .true. endif @@ -3671,7 +3669,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! if all is working propertly, this diagnostic should equal to hfsifrazil CS%id_frazil_heat_tend_2d = register_diag_field('ocean_model',& 'frazil_heat_tendency_2d', diag%axesT1, Time, & - 'Depth integrated heat tendency due to frazil formation','W m-2') + 'Depth integrated heat tendency due to frazil formation', 'W m-2', conversion=US%s_to_T) if (CS%id_frazil_heat_tend_2d > 0) then CS%frazil_tendency_diag = .true. endif diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index a7c8338572..dba311441e 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -26,7 +26,7 @@ module MOM_geothermal real :: dRcv_dT_inplace !< The value of dRcv_dT above which (dRcv_dT is !! negative) the water is heated in place instead !! of moving upward between layers [R degC-1 ~> kg m-3 degC-1]. - real, pointer :: geo_heat(:,:) => NULL() !< The geothermal heat flux [W m-2]. + real, pointer :: geo_heat(:,:) => NULL() !< The geothermal heat flux [J m-2 T-1 ~> W m-2]. real :: geothermal_thick !< The thickness over which geothermal heating is !! applied [m] (not [H]). logical :: apply_geothermal !< If true, geothermal heating will be applied @@ -58,7 +58,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) !! to any available thermodynamic !! fields. Absent fields have NULL !! ptrs. - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: ea !< The amount of fluid moved !! downward into a layer; this !! should be increased due to mixed @@ -391,7 +391,8 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) character(len=48) :: thickness_units ! Local variables character(len=200) :: inputdir, geo_file, filename, geotherm_var - real :: scale + real :: scale ! A constant heat flux or dimensionally rescaled scaling factor + ! [J m-2 T-1 ~> W m-2] or [s T-1 ~> 1] integer :: i, j, isd, ied, jsd, jed, id isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -410,7 +411,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) "The constant geothermal heat flux, a rescaling "//& "factor for the heat flux read from GEOTHERMAL_FILE, or "//& "0 to disable the geothermal heating.", & - units="W m-2 or various", default=0.0) + units="W m-2 or various", default=0.0, scale=US%T_to_s) CS%apply_geothermal = .not.(scale == 0.0) if (.not.CS%apply_geothermal) return @@ -453,7 +454,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) ! post the static geothermal heating field id = register_static_field('ocean_model', 'geo_heat', diag%axesT1, & - 'Geothermal heat flux into ocean', 'W m-2', & + 'Geothermal heat flux into ocean', 'W m-2', conversion=US%s_to_T, & cmor_field_name='hfgeou', cmor_units='W m-2', & cmor_standard_name='upward_geothermal_heat_flux_at_sea_floor', & cmor_long_name='Upward geothermal heat flux at sea floor', & @@ -464,15 +465,15 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) CS%id_internal_heat_heat_tendency=register_diag_field('ocean_model', & 'internal_heat_heat_tendency', diag%axesTL, Time, & 'Heat tendency (in 3D) due to internal (geothermal) sources', & - 'W m-2', v_extensive=.true.) + 'W m-2', conversion=US%s_to_T, v_extensive=.true.) CS%id_internal_heat_temp_tendency=register_diag_field('ocean_model', & 'internal_heat_temp_tendency', diag%axesTL, Time, & 'Temperature tendency (in 3D) due to internal (geothermal) sources', & - 'degC s-1', v_extensive=.true.) + 'degC s-1', conversion=US%s_to_T, v_extensive=.true.) CS%id_internal_heat_h_tendency=register_diag_field('ocean_model', & 'internal_heat_h_tendency', diag%axesTL, Time, & 'Thickness tendency (in 3D) due to internal (geothermal) sources', & - trim(thickness_units), conversion=GV%H_to_MKS, v_extensive=.true.) + trim(thickness_units), conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) end subroutine geothermal_init diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index ff352d5e32..57f7bd2444 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -83,7 +83,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to mixed @@ -122,7 +122,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to mixed diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 2bc42e29ff..dd0887845c 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -55,7 +55,7 @@ module MOM_sponge !! registered by calls to set_up_sponge_field integer, pointer :: col_i(:) => NULL() !< Array of the i-indicies of each of the columns being damped. integer, pointer :: col_j(:) => NULL() !< Array of the j-indicies of each of the columns being damped. - real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each column. + real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each column [T-1 ~> s-1]. real, pointer :: Rcv_ml_ref(:) => NULL() !< The value toward which the mixed layer !! coordinate-density is being damped [R ~> kg m-3]. real, pointer :: Ref_eta(:,:) => NULL() !< The value toward which the interface @@ -65,7 +65,7 @@ module MOM_sponge logical :: do_i_mean_sponge !< If true, apply sponges to the i-mean fields. real, pointer :: Iresttime_im(:) => NULL() !< The inverse restoring time of - !! each row for i-mean sponges. + !! each row for i-mean sponges [T-1 ~> s-1]. real, pointer :: Rcv_ml_ref_im(:) => NULL() !! The value toward which the i-mean !< mixed layer coordinate-density is being damped [R ~> kg m-3]. real, pointer :: Ref_eta_im(:,:) => NULL() !< The value toward which the i-mean @@ -155,7 +155,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then CS%col_i(col) = i ; CS%col_j(col) = j - CS%Iresttime_col(col) = Iresttime(i,j) + CS%Iresttime_col(col) = G%US%T_to_s*Iresttime(i,j) col = col +1 endif enddo ; enddo @@ -172,7 +172,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & allocate(CS%Ref_eta_im(G%jsd:G%jed,G%ke+1)) ; CS%Ref_eta_im(:,:) = 0.0 do j=G%jsc,G%jec - CS%Iresttime_im(j) = Iresttime_i_mean(j) + CS%Iresttime_im(j) = G%US%T_to_s*Iresttime_i_mean(j) enddo do K=1,CS%nz+1 ; do j=G%jsc,G%jec CS%Ref_eta_im(j,K) = int_height_i_mean(j,K) @@ -190,9 +190,11 @@ end subroutine initialize_sponge !> This subroutine sets up diagnostics for the sponges. It is separate !! from initialize_sponge because it requires fields that are not readily !! available where initialize_sponge is called. -subroutine init_sponge_diags(Time, G, diag, CS) +subroutine init_sponge_diags(Time, G, GV, US, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that !! is set by a previous call to initialize_sponge. @@ -201,7 +203,7 @@ subroutine init_sponge_diags(Time, G, diag, CS) CS%diag => diag CS%id_w_sponge = register_diag_field('ocean_model', 'w_sponge', diag%axesTi, & - Time, 'The diapycnal motion due to the sponges', 'm s-1') + Time, 'The diapycnal motion due to the sponges', 'm s-1', conversion=US%s_to_T) end subroutine init_sponge_diags @@ -324,7 +326,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, intent(in) :: dt !< The amount of time covered by this call [s]. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. 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 @@ -378,7 +380,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) real :: damp ! The timestep times the local damping coefficient [nondim]. real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim] real :: damp_1pdamp ! damp_1pdamp is damp/(1 + damp). [nondim] - real :: Idt ! 1.0/dt [s-1]. + real :: Idt ! 1.0/dt times a height unit conversion factor [m H-1 T-1 ~> s-1 or m3 kg-1 s-1]. integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -430,7 +432,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) enddo do j=js,je ; if (CS%Iresttime_im(j) > 0.0) then - damp = dt*CS%Iresttime_im(j) ; damp_1pdamp = damp / (1.0 + damp) + damp = dt * CS%Iresttime_im(j) ; damp_1pdamp = damp / (1.0 + damp) do i=is,ie h_above(i,1) = 0.0 ; h_below(i,nz+1) = 0.0 @@ -478,7 +480,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) ! c is an index for the next 3 lines but a multiplier for the rest of the loop ! Therefore we use c as per C code and increment the index where necessary. i = CS%col_i(c) ; j = CS%col_j(c) - damp = dt*CS%Iresttime_col(c) + damp = dt * CS%Iresttime_col(c) e(1) = 0.0 ; e0 = 0.0 do K=1,nz @@ -576,7 +578,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) if (associated(CS%diag)) then ; if (query_averaging_enabled(CS%diag)) then if (CS%id_w_sponge > 0) then - Idt = GV%H_to_m / dt + Idt = GV%H_to_m / dt ! Do any height unit conversion here for efficiency. do k=1,nz+1 ; do j=js,je ; do i=is,ie w_int(i,j,K) = w_int(i,j,K) * Idt ! Scale values by clobbering array since it is local enddo ; enddo ; enddo From 7e0e5056885c17edb34ba14e8340bcc3e9306009 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 16:47:36 -0400 Subject: [PATCH 194/259] Renamed internal variables dt_in_T to dt Renamed internal variables dt_in_T to dt in multiple files. All answers are bitwise identical. --- src/core/MOM_barotropic.F90 | 46 +++--- src/core/MOM_continuity_PPM.F90 | 152 +++++++++--------- src/parameterizations/lateral/MOM_MEKE.F90 | 8 +- .../lateral/MOM_internal_tides.F90 | 92 +++++------ .../lateral/MOM_lateral_mixing_coeffs.F90 | 6 +- .../lateral/MOM_mixed_layer_restrat.F90 | 44 ++--- .../lateral/MOM_thickness_diffuse.F90 | 42 ++--- .../vertical/MOM_bulk_mixed_layer.F90 | 56 +++---- .../vertical/MOM_diabatic_aux.F90 | 30 ++-- .../vertical/MOM_internal_tide_input.F90 | 6 +- .../vertical/MOM_set_diffusivity.F90 | 12 +- .../vertical/MOM_set_viscosity.F90 | 10 +- .../vertical/MOM_vert_friction.F90 | 96 +++++------ 13 files changed, 300 insertions(+), 300 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index bdb46a4e5f..bdb267524e 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -380,7 +380,7 @@ module MOM_barotropic !! 0.0 and 1.0 determining the scheme. In practice, bebt must be of !! order 0.2 or greater. A forwards-backwards treatment of the !! Coriolis terms is always used. -subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, pbce, & +subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & eta_out, uhbtav, vhbtav, G, GV, US, CS, & visc_rem_u, visc_rem_v, etaav, OBC, BT_cont, eta_PF_start, & @@ -394,7 +394,7 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p !! velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_in !< The initial barotropic free surface height !! anomaly or column mass anomaly [H ~> m or kg m-2]. - real, intent(in) :: dt_in_T !< The time increment to integrate over [T ~> s]. + real, intent(in) :: dt !< The time increment to integrate over [T ~> s]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations, !! [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations, @@ -652,7 +652,7 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p 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_in_T + Idt = 1.0 / dt accel_underflow = CS%vel_underflow * Idt use_BT_cont = .false. @@ -709,17 +709,17 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p 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_in_T/CS%dtbt - 0.0001) + 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, & - & " seconds, max ", ES12.6, ".")') (US%T_to_s*dt_in_T/nstep), US%T_to_s*CS%dtbt_max + & " seconds, max ", ES12.6, ".")') (US%T_to_s*dt/nstep), US%T_to_s*CS%dtbt_max call MOM_mesg(mesg, 3) endif CS%nstep_last = nstep ! Set the actual barotropic time step. Instep = 1.0 / real(nstep) - dtbt = dt_in_T * Instep + dtbt = dt * Instep bebt = CS%bebt be_proj = CS%bebt mass_accel_to_Z = 1.0 / GV%Rho0 @@ -738,7 +738,7 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) then do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) if (do_hifreq_output) & - time_bt_start = time_end_in - real_to_time(US%T_to_s*dt_in_T) + time_bt_start = time_end_in - real_to_time(US%T_to_s*dt) endif !--- begin setup for group halo update @@ -1260,7 +1260,7 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p !$OMP find_etaav,jsvf,jevf,isvf,ievf,eta_sum,eta_wtd, & !$OMP ubt_sum,uhbt_sum,PFu_bt_sum,Coru_bt_sum,ubt_wtd,& !$OMP ubt_trans,vbt_sum,vhbt_sum,PFv_bt_sum, & -!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt_in_T,dtbt, & +!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt,dtbt, & !$OMP Rayleigh_u, Rayleigh_v, & !$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt,US) & !$OMP private(u_max_cor,v_max_cor,eta_cor_max,Htot) @@ -1358,7 +1358,7 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p ! CFL_cor. u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) - eta_cor_max = dt_in_T * (CS%IareaT(i,j) * & + eta_cor_max = dt * (CS%IareaT(i,j) * & (((find_uhbt(u_max_cor, BTCL_u(I,j), US) + uhbt0(I,j)) - & (find_uhbt(-u_max_cor, BTCL_u(I-1,j), US) + uhbt0(I-1,j))) + & ((find_vhbt(v_max_cor, BTCL_v(i,J), US) + vhbt0(i,J)) - & @@ -1374,8 +1374,8 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p endif endif ; enddo ; enddo else ; do j=js,je ; do i=is,ie - if (abs(CS%eta_cor(i,j)) > dt_in_T*CS%eta_cor_bound(i,j)) & - CS%eta_cor(i,j) = sign(dt_in_T*CS%eta_cor_bound(i,j), CS%eta_cor(i,j)) + if (abs(CS%eta_cor(i,j)) > dt*CS%eta_cor_bound(i,j)) & + CS%eta_cor(i,j) = sign(dt*CS%eta_cor_bound(i,j), CS%eta_cor(i,j)) enddo ; enddo ; endif ; endif !$OMP do do j=js,je ; do i=is,ie @@ -1489,9 +1489,9 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p if (project_velocity) then ; eta_PF_BT => eta ; else ; eta_PF_BT => eta_pred ; endif if (CS%dt_bt_filter >= 0.0) then - dt_filt = 0.5 * max(0.0, min(CS%dt_bt_filter, 2.0*dt_in_T)) + dt_filt = 0.5 * max(0.0, min(CS%dt_bt_filter, 2.0*dt)) else - dt_filt = 0.5 * max(0.0, dt_in_T * min(-CS%dt_bt_filter, 2.0)) + dt_filt = 0.5 * max(0.0, dt * min(-CS%dt_bt_filter, 2.0)) endif nfilter = ceiling(dt_filt / dtbt) @@ -1549,21 +1549,21 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p if (CS%clip_velocity) then do j=jsv,jev ; do I=isv-1,iev - if ((ubt(I,j) * (dt_in_T * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + if ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then ! Add some error reporting later. - ubt(I,j) = (-0.95*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt_in_T * G%dy_Cu(I,j))) - elseif ((ubt(I,j) * (dt_in_T * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + ubt(I,j) = (-0.95*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) + elseif ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then ! Add some error reporting later. - ubt(I,j) = (0.95*CS%CFL_trunc) * (G%areaT(i,j) / (dt_in_T * G%dy_Cu(I,j))) + ubt(I,j) = (0.95*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) endif enddo ; enddo do J=jsv-1,jev ; do i=isv,iev - if ((vbt(i,J) * (dt_in_T * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + if ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then ! Add some error reporting later. - vbt(i,J) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt_in_T * G%dx_Cv(i,J))) - elseif ((vbt(i,J) * (dt_in_T * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + vbt(i,J) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) + elseif ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then ! Add some error reporting later. - vbt(i,J) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt_in_T * G%dx_Cv(i,J))) + vbt(i,J) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) endif enddo ; enddo endif @@ -2139,13 +2139,13 @@ subroutine btstep(U_in, V_in, eta_in, dt_in_T, bc_accel_u, bc_accel_v, forces, p ! symmetric-memory computational domain, not in the wide halo regions. if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then - u_accel_bt(I,j) = (ubt_wtd(I,j) - ubt_first(I,j)) / dt_in_T + u_accel_bt(I,j) = (ubt_wtd(I,j) - ubt_first(I,j)) / dt do k=1,nz ; accel_layer_u(I,j,k) = u_accel_bt(I,j) ; enddo endif enddo ; enddo ; endif if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then - v_accel_bt(i,J) = (vbt_wtd(i,J) - vbt_first(i,J)) / dt_in_T + v_accel_bt(i,J) = (vbt_wtd(i,J) - vbt_first(i,J)) / dt do k=1,nz ; accel_layer_v(i,J,k) = v_accel_bt(i,J) ; enddo endif enddo ; enddo ; endif diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index a2a125eabe..24c5bf7def 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -73,7 +73,7 @@ module MOM_continuity_PPM !> Time steps the layer thicknesses, using a monotonically limit, directionally split PPM scheme, !! based on Lin (1994). -subroutine continuity_PPM(u, v, hin, h, uh, vh, dt_in_T, G, GV, US, CS, uhbt, vhbt, OBC, & +subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, uhbt, vhbt, OBC, & visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(continuity_PPM_CS), pointer :: CS !< Module's control structure. @@ -89,7 +89,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt_in_T, G, GV, US, CS, uhbt, vh intent(out) :: uh !< Zonal volume flux, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(out) :: vh !< Meridional volume flux, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G)), & @@ -149,12 +149,12 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt_in_T, G, GV, US, CS, uhbt, vh ! First, advect zonally. LB%ish = G%isc ; LB%ieh = G%iec LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil - call zonal_mass_flux(u, hin, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, visc_rem_u, u_cor, BT_cont) + call zonal_mass_flux(u, hin, uh, dt, G, GV, US, CS, LB, uhbt, OBC, visc_rem_u, u_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = hin(i,j,k) - dt_in_T * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) + h(i,j,k) = hin(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) ! Uncomment this line to prevent underflow. ! if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo @@ -164,12 +164,12 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt_in_T, G, GV, US, CS, uhbt, vh ! Now advect meridionally, using the updated thicknesses to determine ! the fluxes. - call meridional_mass_flux(v, h, vh, dt_in_T, G, GV, US, CS, LB, vhbt, OBC, visc_rem_v, v_cor, BT_cont) + call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, LB, vhbt, OBC, visc_rem_v, v_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = h(i,j,k) - dt_in_T * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) + h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) ! This line prevents underflow. if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo @@ -180,24 +180,24 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt_in_T, G, GV, US, CS, uhbt, vh LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil LB%jsh = G%jsc ; LB%jeh = G%jec - call meridional_mass_flux(v, hin, vh, dt_in_T, G, GV, US, CS, LB, vhbt, OBC, visc_rem_v, v_cor, BT_cont) + call meridional_mass_flux(v, hin, vh, dt, G, GV, US, CS, LB, vhbt, OBC, visc_rem_v, v_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = hin(i,j,k) - dt_in_T * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) + h(i,j,k) = hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo ; enddo call cpu_clock_end(id_clock_update) ! Now advect zonally, using the updated thicknesses to determine ! the fluxes. LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec - call zonal_mass_flux(u, h, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, visc_rem_u, u_cor, BT_cont) + call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, LB, uhbt, OBC, visc_rem_u, u_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = h(i,j,k) - dt_in_T * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) + h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) ! This line prevents underflow. if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo @@ -208,7 +208,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt_in_T, G, GV, US, CS, uhbt, vh end subroutine continuity_PPM !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. -subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & +subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & visc_rem_u, u_cor, BT_cont) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. @@ -219,7 +219,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(out) :: uh !< Volume flux through zonal faces = u*h*dy !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. @@ -278,8 +278,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & endif ; endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke - CFL_dt = CS%CFL_limit_adjust / (dt_in_T) - I_dt = 1.0 / (dt_in_T) + CFL_dt = CS%CFL_limit_adjust / dt + I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt call cpu_clock_begin(id_clock_update) @@ -300,7 +300,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & call cpu_clock_begin(id_clock_correct) !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_L,h_R,use_visc_rem,visc_rem_u, & -!$OMP uh,dt_in_T,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & +!$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & !$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC) & !$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & !$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W,any_simple_OBC ) & @@ -315,7 +315,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & enddo ; endif call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), & uh(:,j,k), duhdu(:,k), visc_rem(:,k), & - dt_in_T, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do I=ish-1,ieh if (OBC%segment(OBC%segnum_u(I,j))%specified) & @@ -419,7 +419,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & if (present(uhbt)) then call zonal_flux_adjust(u, h_in, h_L, h_R, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & - du_max_CFL, du_min_CFL, dt_in_T, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & j, ish, ieh, do_I, .true., uh, OBC=OBC) if (present(u_cor)) then ; do k=1,nz @@ -434,7 +434,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & if (set_BT_cont) then call set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0,& - du_max_CFL, du_min_CFL, dt_in_T, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) if (any_simple_OBC) then do I=ish-1,ieh @@ -487,10 +487,10 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then if (present(u_cor)) then - call zonal_face_thickness(u_cor, h_in, h_L, h_R, BT_cont%h_u, dt_in_T, G, US, LB, & + call zonal_face_thickness(u_cor, h_in, h_L, h_R, BT_cont%h_u, dt, G, US, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_u, OBC) else - call zonal_face_thickness(u, h_in, h_L, h_R, BT_cont%h_u, dt_in_T, G, US, LB, & + call zonal_face_thickness(u, h_in, h_L, h_R, BT_cont%h_u, dt, G, US, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_u, OBC) endif endif ; endif @@ -498,7 +498,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt_in_T, G, GV, US, CS, LB, uhbt, OBC, & end subroutine zonal_mass_flux !> Evaluates the zonal mass or volume fluxes in a layer. -subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt_in_T, G, US, j, & +subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & ish, ieh, do_I, vol_CFL, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -514,7 +514,7 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt_in_T, G, US, !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)), intent(inout) :: duhdu !< Partial derivative of uh !! with u [H L ~> m2 or kg m-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. @@ -539,15 +539,15 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt_in_T, G, US, do I=ish-1,ieh ; if (do_I(I)) then ! Set new values of uh and duhdu. if (u(I) > 0.0) then - if (vol_CFL) then ; CFL = (u(I) * dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i,j)) - else ; CFL = u(I) * dt_in_T * G%IdxT(i,j) ; endif + if (vol_CFL) then ; CFL = (u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + else ; CFL = u(I) * dt * G%IdxT(i,j) ; endif curv_3 = h_L(i) + h_R(i) - 2.0*h(i) uh(I) = G%dy_Cu(I,j) * u(I) * & (h_R(i) + CFL * (0.5*(h_L(i) - h_R(i)) + curv_3*(CFL - 1.5))) h_marg = h_R(i) + CFL * ((h_L(i) - h_R(i)) + 3.0*curv_3*(CFL - 1.0)) elseif (u(I) < 0.0) then - if (vol_CFL) then ; CFL = (-u(I) * dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) - else ; CFL = -u(I) * dt_in_T * G%IdxT(i+1,j) ; endif + if (vol_CFL) then ; CFL = (-u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + else ; CFL = -u(I) * dt * G%IdxT(i+1,j) ; endif curv_3 = h_L(i+1) + h_R(i+1) - 2.0*h(i+1) uh(I) = G%dy_Cu(I,j) * u(I) * & (h_L(i+1) + CFL * (0.5*(h_R(i+1)-h_L(i+1)) + curv_3*(CFL - 1.5))) @@ -575,7 +575,7 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt_in_T, G, US, end subroutine zonal_flux_layer !> Sets the effective interface thickness at each zonal velocity point. -subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt_in_T, G, US, LB, vol_CFL, & +subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, US, LB, vol_CFL, & marginal, visc_rem_u, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -586,7 +586,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt_in_T, G, US, LB, vol_CFL real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the !! reconstruction [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_u !< Thickness at zonal faces [H ~> m or kg m-2]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. logical, intent(in) :: vol_CFL !< If true, rescale the ratio @@ -614,14 +614,14 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt_in_T, G, US, LB, vol_CFL !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg) do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh if (u(I,j,k) > 0.0) then - if (vol_CFL) then ; CFL = (u(I,j,k) * dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i,j)) - else ; CFL = u(I,j,k) * dt_in_T * G%IdxT(i,j) ; endif + if (vol_CFL) then ; CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + else ; CFL = u(I,j,k) * dt * G%IdxT(i,j) ; endif curv_3 = h_L(i,j,k) + h_R(i,j,k) - 2.0*h(i,j,k) h_avg = h_R(i,j,k) + CFL * (0.5*(h_L(i,j,k) - h_R(i,j,k)) + curv_3*(CFL - 1.5)) h_marg = h_R(i,j,k) + CFL * ((h_L(i,j,k) - h_R(i,j,k)) + 3.0*curv_3*(CFL - 1.0)) elseif (u(I,j,k) < 0.0) then - if (vol_CFL) then ; CFL = (-u(I,j,k)*dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) - else ; CFL = -u(I,j,k) * dt_in_T * G%IdxT(i+1,j) ; endif + if (vol_CFL) then ; CFL = (-u(I,j,k)*dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + else ; CFL = -u(I,j,k) * dt * G%IdxT(i+1,j) ; endif curv_3 = h_L(i+1,j,k) + h_R(i+1,j,k) - 2.0*h(i+1,j,k) h_avg = h_L(i+1,j,k) + CFL * (0.5*(h_R(i+1,j,k)-h_L(i+1,j,k)) + curv_3*(CFL - 1.5)) h_marg = h_L(i+1,j,k) + CFL * ((h_R(i+1,j,k)-h_L(i+1,j,k)) + & @@ -683,7 +683,7 @@ end subroutine zonal_face_thickness !> Returns the barotropic velocity adjustment that gives the !! desired barotropic (layer-summed) transport. subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & - du, du_max_CFL, du_min_CFL, dt_in_T, G, US, CS, visc_rem, & + du, du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & j, ish, ieh, do_I_in, full_precision, uh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -711,7 +711,7 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & !! of du_err with du at 0 adjustment [H L ~> m2 or kg m-1]. real, dimension(SZIB_(G)), intent(out) :: du !< !! The barotropic velocity adjustment [L T-1 ~> m s-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. integer, intent(in) :: j !< Spatial index. @@ -779,7 +779,7 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & enddo domore = .false. do I=ish-1,ieh ; if (do_I(I)) then - if ((dt_in_T * min(G%IareaT(i,j),G%IareaT(i+1,j))*abs(uh_err(I)) > tol_eta) .or. & + if ((dt * min(G%IareaT(i,j),G%IareaT(i+1,j))*abs(uh_err(I)) > tol_eta) .or. & (CS%better_iter .and. ((abs(uh_err(I)) > tol_vel * duhdu_tot(I)) .or. & (abs(uh_err(I)) > uh_err_best(I))) )) then ! Use Newton's method, provided it stays bounded. Otherwise bisect @@ -818,7 +818,7 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & do I=ish-1,ieh ; u_new(I) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo call zonal_flux_layer(u_new, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), & uh_aux(:,k), duhdu(:,k), visc_rem(:,k), & - dt_in_T, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) enddo ; endif if (itt < max_itts) then @@ -847,7 +847,7 @@ end subroutine zonal_flux_adjust !> Sets a structure that describes the zonal barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, & - du_max_CFL, du_min_CFL, dt_in_T, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -867,7 +867,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, !! value of du [L T-1 ~> m s-1]. real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable !! value of du [L T-1 ~> m s-1]. - real, intent(in) :: dt_in_T !< Time increment [s]. + real, intent(in) :: dt !< Time increment [s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the @@ -915,13 +915,13 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, logical :: domore integer :: i, k, nz - nz = G%ke ; Idt = 1.0 / (dt_in_T) + nz = G%ke ; Idt = 1.0 / dt min_visc_rem = 0.1 ; CFL_min = 1e-6 ! Diagnose the zero-transport correction, du0. do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo call zonal_flux_adjust(u, h_in, h_L, h_R, zeros, uh_tot_0, duhdu_tot_0, du0, & - du_max_CFL, du_min_CFL, dt_in_T, G, US, CS, visc_rem, & + du_max_CFL, du_min_CFL, dt, G, US, CS, visc_rem, & j, ish, ieh, do_I, .true.) ! Determine the westerly- and easterly- fluxes. Choose a sufficiently @@ -963,11 +963,11 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, u_0(I) = u(I,j,k) + du0(I) * visc_rem(I,k) endif ; enddo call zonal_flux_layer(u_0, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_0, duhdu_0, & - visc_rem(:,k), dt_in_T, G, US, j, ish, ieh, do_I, CS%vol_CFL) + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL) call zonal_flux_layer(u_L, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_L, duhdu_L, & - visc_rem(:,k), dt_in_T, G, US, j, ish, ieh, do_I, CS%vol_CFL) + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL) call zonal_flux_layer(u_R, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_R, duhdu_R, & - visc_rem(:,k), dt_in_T, G, US, j, ish, ieh, do_I, CS%vol_CFL) + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL) do I=ish-1,ieh ; if (do_I(I)) then FAmt_0(I) = FAmt_0(I) + duhdu_0(I) FAmt_L(I) = FAmt_L(I) + duhdu_L(I) @@ -1009,7 +1009,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, end subroutine set_zonal_BT_cont !> Calculates the mass or volume fluxes through the meridional faces, and other related quantities. -subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, OBC, & +subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & visc_rem_v, v_cor, BT_cont) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. @@ -1018,7 +1018,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O !! calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vh !< Volume flux through meridional !! faces = v*h*dx [H m2 s-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure.G type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. @@ -1077,8 +1077,8 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O endif ; endif ; endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke - CFL_dt = CS%CFL_limit_adjust / (dt_in_T) - I_dt = 1.0 / (dt_in_T) + CFL_dt = CS%CFL_limit_adjust / dt + I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt call cpu_clock_begin(id_clock_update) @@ -1099,7 +1099,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O call cpu_clock_begin(id_clock_correct) !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_L,h_R,vh,use_visc_rem, & -!$OMP visc_rem_v,dt_in_T,US,G,GV,CS,local_specified_BC,OBC,vhbt, & +!$OMP visc_rem_v,dt,US,G,GV,CS,local_specified_BC,OBC,vhbt, & !$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC ) & !$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & !$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & @@ -1115,7 +1115,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O enddo ; endif call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), & vh(:,J,k), dvhdv(:,k), visc_rem(:,k), & - dt_in_T, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do i=ish,ieh if (OBC%segment(OBC%segnum_v(i,J))%specified) & @@ -1215,7 +1215,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O if (present(vhbt)) then call meridional_flux_adjust(v, h_in, h_L, h_R, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & - dv_max_CFL, dv_min_CFL, dt_in_T, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & j, ish, ieh, do_I, .true., vh, OBC=OBC) if (present(v_cor)) then ; do k=1,nz @@ -1229,7 +1229,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O if (set_BT_cont) then call set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0,& - dv_max_CFL, dv_min_CFL, dt_in_T, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & visc_rem_max, J, ish, ieh, do_I) if (any_simple_OBC) then do i=ish,ieh @@ -1282,10 +1282,10 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then if (present(v_cor)) then - call merid_face_thickness(v_cor, h_in, h_L, h_R, BT_cont%h_v, dt_in_T, G, US, LB, & + call merid_face_thickness(v_cor, h_in, h_L, h_R, BT_cont%h_v, dt, G, US, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_v, OBC) else - call merid_face_thickness(v, h_in, h_L, h_R, BT_cont%h_v, dt_in_T, G, US, LB, & + call merid_face_thickness(v, h_in, h_L, h_R, BT_cont%h_v, dt, G, US, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_v, OBC) endif endif ; endif @@ -1293,7 +1293,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt_in_T, G, GV, US, CS, LB, vhbt, O end subroutine meridional_mass_flux !> Evaluates the meridional mass or volume fluxes in a layer. -subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt_in_T, G, US, J, & +subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & ish, ieh, do_I, vol_CFL, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. @@ -1312,7 +1312,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt_in_T, G, US, !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G)), intent(inout) :: dvhdv !< Partial derivative of vh with v !! [H L ~> m2 or kg m-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. @@ -1336,16 +1336,16 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt_in_T, G, US, do i=ish,ieh ; if (do_I(i)) then if (v(i) > 0.0) then - if (vol_CFL) then ; CFL = (v(i) * dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j)) - else ; CFL = v(i) * dt_in_T * G%IdyT(i,j) ; endif + if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif curv_3 = h_L(i,j) + h_R(i,j) - 2.0*h(i,j) vh(i) = G%dx_Cv(i,J) * v(i) * ( h_R(i,j) + CFL * & (0.5*(h_L(i,j) - h_R(i,j)) + curv_3*(CFL - 1.5)) ) h_marg = h_R(i,j) + CFL * ((h_L(i,j) - h_R(i,j)) + & 3.0*curv_3*(CFL - 1.0)) elseif (v(i) < 0.0) then - if (vol_CFL) then ; CFL = (-v(i) * dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) - else ; CFL = -v(i) * dt_in_T * G%IdyT(i,j+1) ; endif + if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif curv_3 = h_L(i,j+1) + h_R(i,j+1) - 2.0*h(i,j+1) vh(i) = G%dx_Cv(i,J) * v(i) * ( h_L(i,j+1) + CFL * & (0.5*(h_R(i,j+1)-h_L(i,j+1)) + curv_3*(CFL - 1.5)) ) @@ -1374,7 +1374,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt_in_T, G, US, end subroutine merid_flux_layer !> Sets the effective interface thickness at each meridional velocity point. -subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt_in_T, G, US, LB, vol_CFL, & +subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, US, LB, vol_CFL, & marginal, visc_rem_v, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. @@ -1386,7 +1386,7 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt_in_T, G, US, LB, vol_CFL !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: h_v !< Thickness at meridional faces, !! [H ~> m or kg m-2]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: vol_CFL !< If true, rescale the ratio @@ -1413,15 +1413,15 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt_in_T, G, US, LB, vol_CFL !$OMP parallel do default(shared) private(CFL,curv_3,h_marg,h_avg) do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh if (v(i,J,k) > 0.0) then - if (vol_CFL) then ; CFL = (v(i,J,k) * dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j)) - else ; CFL = v(i,J,k) * dt_in_T * G%IdyT(i,j) ; endif + if (vol_CFL) then ; CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + else ; CFL = v(i,J,k) * dt * G%IdyT(i,j) ; endif curv_3 = h_L(i,j,k) + h_R(i,j,k) - 2.0*h(i,j,k) h_avg = h_R(i,j,k) + CFL * (0.5*(h_L(i,j,k) - h_R(i,j,k)) + curv_3*(CFL - 1.5)) h_marg = h_R(i,j,k) + CFL * ((h_L(i,j,k) - h_R(i,j,k)) + & 3.0*curv_3*(CFL - 1.0)) elseif (v(i,J,k) < 0.0) then - if (vol_CFL) then ; CFL = (-v(i,J,k)*dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) - else ; CFL = -v(i,J,k) * dt_in_T * G%IdyT(i,j+1) ; endif + if (vol_CFL) then ; CFL = (-v(i,J,k)*dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + else ; CFL = -v(i,J,k) * dt * G%IdyT(i,j+1) ; endif curv_3 = h_L(i,j+1,k) + h_R(i,j+1,k) - 2.0*h(i,j+1,k) h_avg = h_L(i,j+1,k) + CFL * (0.5*(h_R(i,j+1,k)-h_L(i,j+1,k)) + curv_3*(CFL - 1.5)) h_marg = h_L(i,j+1,k) + CFL * ((h_R(i,j+1,k)-h_L(i,j+1,k)) + & @@ -1483,7 +1483,7 @@ end subroutine merid_face_thickness !> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport. subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & - dv, dv_max_CFL, dv_min_CFL, dt_in_T, G, US, CS, visc_rem, & + dv, dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & j, ish, ieh, do_I_in, full_precision, vh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -1510,7 +1510,7 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with !! dv at 0 adjustment [H L ~> m2 or kg m-1]. real, dimension(SZI_(G)), intent(out) :: dv !< The barotropic velocity adjustment [L T-1 ~> m s-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. integer, intent(in) :: j !< Spatial index. @@ -1578,7 +1578,7 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 enddo domore = .false. do i=ish,ieh ; if (do_I(i)) then - if ((dt_in_T * min(G%IareaT(i,j),G%IareaT(i,j+1))*abs(vh_err(i)) > tol_eta) .or. & + if ((dt * min(G%IareaT(i,j),G%IareaT(i,j+1))*abs(vh_err(i)) > tol_eta) .or. & (CS%better_iter .and. ((abs(vh_err(i)) > tol_vel * dvhdv_tot(i)) .or. & (abs(vh_err(i)) > vh_err_best(i))) )) then ! Use Newton's method, provided it stays bounded. Otherwise bisect @@ -1617,7 +1617,7 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 do i=ish,ieh ; v_new(i) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo call merid_flux_layer(v_new, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), & vh_aux(:,k), dvhdv(:,k), visc_rem(:,k), & - dt_in_T, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) enddo ; endif if (itt < max_itts) then @@ -1646,7 +1646,7 @@ end subroutine meridional_flux_adjust !> Sets of a structure that describes the meridional barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, & - dv_max_CFL, dv_min_CFL, dt_in_T, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. @@ -1666,7 +1666,7 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, !! of dv [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value !! of dv [L T-1 ~> m s-1]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the @@ -1714,13 +1714,13 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, logical :: domore integer :: i, k, nz - nz = G%ke ; Idt = 1.0/(dt_in_T) + nz = G%ke ; Idt = 1.0 / dt min_visc_rem = 0.1 ; CFL_min = 1e-6 ! Diagnose the zero-transport correction, dv0. do i=ish,ieh ; zeros(i) = 0.0 ; enddo call meridional_flux_adjust(v, h_in, h_L, h_R, zeros, vh_tot_0, dvhdv_tot_0, dv0, & - dv_max_CFL, dv_min_CFL, dt_in_T, G, US, CS, visc_rem, & + dv_max_CFL, dv_min_CFL, dt, G, US, CS, visc_rem, & j, ish, ieh, do_I, .true.) ! Determine the southerly- and northerly- fluxes. Choose a sufficiently @@ -1762,11 +1762,11 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, v_0(i) = v(I,j,k) + dv0(i) * visc_rem(i,k) endif ; enddo call merid_flux_layer(v_0, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_0, dvhdv_0, & - visc_rem(:,k), dt_in_T, G, US, J, ish, ieh, do_I, CS%vol_CFL) + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL) call merid_flux_layer(v_L, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_L, dvhdv_L, & - visc_rem(:,k), dt_in_T, G, US, J, ish, ieh, do_I, CS%vol_CFL) + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL) call merid_flux_layer(v_R, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_R, dvhdv_R, & - visc_rem(:,k), dt_in_T, G, US, J, ish, ieh, do_I, CS%vol_CFL) + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL) do i=ish,ieh ; if (do_I(i)) then FAmt_0(i) = FAmt_0(i) + dvhdv_0(i) FAmt_L(i) = FAmt_L(i) + dvhdv_L(i) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 2b509a0a72..e9d1938420 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -97,7 +97,7 @@ module MOM_MEKE !> Integrates forward-in-time the MEKE eddy energy equation. !! See \ref section_MEKE_equations. -subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt_in_T, G, GV, US, CS, hu, hv) +subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, 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. @@ -106,7 +106,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt_in_T, G, GV, US, CS, real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. - real, intent(in) :: dt_in_T !< Model(baroclinic) time-step [T ~> s]. + real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. type(MEKE_CS), pointer :: CS !< MEKE control structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: hu !< Accumlated zonal mass flux [H L2 ~> m3 or kg]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: hv !< Accumlated meridional mass flux [H L2 ~> m3 or kg] @@ -190,7 +190,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt_in_T, G, GV, US, CS, call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m) endif - sdt = dt_in_T*CS%MEKE_dtScale ! Scaled dt to use for time-stepping + sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping Rho0 = GV%Rho0 mass_neglect = GV%H_to_RZ * GV%H_subroundoff cdrag2 = CS%cdrag**2 @@ -457,7 +457,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt_in_T, G, GV, US, CS, if (CS%MEKE_advection_factor>0.) then !### I think that for dimensional consistency, this should be: ! advFac = GV%H_to_RZ * CS%MEKE_advection_factor / sdt - advFac = US%kg_m3_to_R*GV%H_to_Z * CS%MEKE_advection_factor / dt_in_T + advFac = US%kg_m3_to_R*GV%H_to_Z * CS%MEKE_advection_factor / dt !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ! Here the units of the quantities added to MEKE_uflux and MEKE_vflux are [m L4 T-3]. diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 21e26d1674..d6616a5ee0 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -149,7 +149,7 @@ module MOM_internal_tides !> Calls subroutines in this file that are needed to refract, propagate, !! and dissipate energy density of the internal tide. -subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in_T, & +subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & G, GV, US, 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. @@ -163,7 +163,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read !! from file [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. - real, intent(in) :: dt_in_T !< Length of time over which to advance + real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. @@ -223,7 +223,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt_in_T*frac_per_sector*(1.0-CS%q_itides) * & + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo ; enddo elseif (CS%energized_angle <= CS%nAngle) then @@ -233,7 +233,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt_in_T*frac_per_sector*(1.0-CS%q_itides) * & + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & TKE_itidal_input(i,j) enddo ; enddo ; enddo ; enddo else @@ -251,7 +251,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in ! Apply half the refraction. do m=1,CS%nMode ; do fr=1,CS%nFreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt_in_T, & + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%nAngle, CS%use_PPMang) enddo ; enddo @@ -278,7 +278,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in ! Propagate the waves. do m=1,CS%NMode ; do fr=1,CS%Nfreq - call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt_in_T, & + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & G, US, CS, CS%NAngle) enddo ; enddo @@ -300,7 +300,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in ! Apply the other half of the refraction. do m=1,CS%NMode ; do fr=1,CS%Nfreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt_in_T, & + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%NAngle, CS%use_PPMang) enddo ; enddo @@ -338,7 +338,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt_in_T * CS%decay_rate) ! implicit update + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%decay_rate) ! implicit update enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later @@ -367,7 +367,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt_in_T * drag_scale(i,j)) ! implicit update + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j)) ! implicit update enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later @@ -406,7 +406,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step call itidal_lowmode_loss(G, US, CS, Nb, Ub, CS%En, CS%TKE_itidal_loss_fixed, & - CS%TKE_itidal_loss, dt_in_T, full_halos=.false.) + CS%TKE_itidal_loss, dt, full_halos=.false.) endif ! Check for En<0 - for debugging, delete later do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -442,13 +442,13 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in if (Fr2_max > 1.0) then En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging ! Calculate effective decay rate [s-1] if breaking occurs over a time step - loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt_in_T) + loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) ! Update energy En_new = CS%En(i,j,a,fr,m)/Fr2_max ! for debugging - En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt_in_T ! for debugging + En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt ! for debugging ! Re-scale (reduce) energy due to breaking CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max ! Check (for debugging only) @@ -461,7 +461,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt_in enddo ! Check (for debugging) Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) - TKE_Froude_loss_check = abs(Delta_E_check)/dt_in_T + TKE_Froude_loss_check = abs(Delta_E_check)/dt TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot) > 1e-10) then call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & @@ -632,7 +632,7 @@ end subroutine sum_En !> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt_in_T, full_halos) +subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), pointer :: CS !< The control structure returned by a @@ -650,7 +650,7 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] !! (q*rho*kappa*h^2*N*U^2). - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. logical,optional, intent(in) :: full_halos !< If true, do the calculation over the !! entirecomputational domain. ! Local variables @@ -691,7 +691,7 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, frac_per_sector = En(i,j,a,fr,m)/En_tot TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! Wm-2 loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] - En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt_in_T*loss_rate) + En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) enddo else ! no loss if no energy @@ -703,8 +703,8 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, ! do a=1,CS%nAngle ! frac_per_sector = En(i,j,a,fr,m)/En_tot ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if (TKE_loss(i,j,a,fr,m)*dt_in_T <= En(i,j,a,fr,m))then - ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt_in_T + ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then + ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt ! else ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than avalable, "// & ! " setting En to zero.", all_print=.true.) @@ -742,7 +742,7 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) end subroutine get_lowmode_loss !> Implements refraction on the internal waves at a single frequency. -subroutine refract(En, cn, freq, dt_in_T, G, US, NAngle, use_PPMang) +subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -753,7 +753,7 @@ subroutine refract(En, cn, freq, dt_in_T, G, US, NAngle, use_PPMang) real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. - real, intent(in) :: dt_in_T !< Time step [T ~> s]. + real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: use_PPMang !< If true, use PPM for advection rather !! than upwind. @@ -786,7 +786,7 @@ subroutine refract(En, cn, freq, dt_in_T, G, US, NAngle, use_PPMang) Ifreq = 1.0 / freq cn_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. Angle_size = (8.0*atan(1.0)) / (real(NAngle)) - dt_Angle_size = dt_in_T / Angle_size + dt_Angle_size = dt / Angle_size do A=asd,aed angle = (real(A) - 0.5) * Angle_size @@ -856,7 +856,7 @@ subroutine refract(En, cn, freq, dt_in_T, G, US, NAngle, use_PPMang) else ! Use PPM do i=is,ie - call PPM_angular_advect(En2d(i,:),CFL_ang(i,j,:),Flux_E(i,:),NAngle,dt_in_T,stencil) + call PPM_angular_advect(En2d(i,:),CFL_ang(i,j,:),Flux_E(i,:),NAngle,dt,stencil) enddo endif @@ -872,10 +872,10 @@ end subroutine refract !> This subroutine calculates the 1-d flux for advection in angular space using a monotonic !! piecewise parabolic scheme. This needs to be called from within i and j spatial loops. -subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt_in_T, halo_ang) +subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: En2d !< The internal gravity wave energy density as a @@ -893,7 +893,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt_in_T, halo_ang) integer :: a real :: aR, aL, dMx, dMn, Ep, Ec, Em, dA, mA, a6 - I_dt = 1 / dt_in_T + I_dt = 1 / dt Angle_size = (8.0*atan(1.0)) / (real(NAngle)) I_Angle_size = 1 / Angle_size Flux_En(:) = 0 @@ -922,7 +922,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt_in_T, halo_ang) flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) !flux = u_ang*( aR - 0.5 * CFL_ang(A) * ( ( aR - aL ) - a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) ! CALCULATE AMOUNT FLUXED (Jm-2) - Flux_En(A) = dt_in_T * flux + Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux else ! Implementation of PPM-H3 @@ -946,14 +946,14 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt_in_T, halo_ang) flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) !flux = u_ang*( aL + 0.5 * CFL_ang(A) * ( ( aR - aL ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) ! CALCULATE AMOUNT FLUXED (Jm-2) - Flux_En(A) = dt_in_T * flux + Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux endif enddo end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt_in_T, G, US, CS, NAngle) +subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -964,7 +964,7 @@ subroutine propagate(En, cn, freq, dt_in_T, G, US, CS, NAngle) real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. - real, intent(in) :: dt_in_T !< Time step [T ~> s]. + real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), pointer :: CS !< The control structure returned by a !! previous call to int_tide_init. @@ -1023,7 +1023,7 @@ subroutine propagate(En, cn, freq, dt_in_T, G, US, CS, NAngle) do a=1,na ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie - call propagate_corner_spread(En(:,:,a), a, NAngle, speed, dt_in_T, G, CS, LB) + call propagate_corner_spread(En(:,:,a), a, NAngle, speed, dt, G, CS, LB) enddo ! a-loop else ! IMPLEMENT PPM ADVECTION IN HORIZONTAL----------------------- @@ -1058,7 +1058,7 @@ subroutine propagate(En, cn, freq, dt_in_T, G, US, CS, NAngle) ! Apply propagation in x-direction (reflection included) LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_x(En(:,:,:), speed_x, Cgx_av(:), dCgx(:), dt_in_T, G, US, CS%nAngle, CS, LB) + call propagate_x(En(:,:,:), speed_x, Cgx_av(:), dCgx(:), dt, G, US, CS%nAngle, CS, LB) ! Check for energy conservation on computational domain (for debugging) !call sum_En(G,CS,En(:,:,:),'post-propagate_x') @@ -1069,7 +1069,7 @@ subroutine propagate(En, cn, freq, dt_in_T, G, US, CS, NAngle) ! Apply propagation in y-direction (reflection included) ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_y(En(:,:,:), speed_y, Cgy_av(:), dCgy(:), dt_in_T, G, US, CS%nAngle, CS, LB) + call propagate_y(En(:,:,:), speed_y, Cgy_av(:), dCgy(:), dt, G, US, CS%nAngle, CS, LB) ! Check for energy conservation on computational domain (for debugging) !call sum_En(G,CS,En(:,:,:),'post-propagate_y') @@ -1080,7 +1080,7 @@ end subroutine propagate !> This subroutine does first-order corner advection. It was written with the hopes !! of smoothing out the garden sprinkler effect, but is too numerically diffusive to !! be of much use as of yet. It is not yet compatible with reflection schemes (BDM). -subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt_in_T, G, CS, LB) +subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(inout) :: En !< The energy density integrated over an angular @@ -1091,7 +1091,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt_in_T, integer, intent(in) :: energized_wedge !< Index of current ray direction. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(int_tide_CS), pointer :: CS !< The control structure returned by a previous !! call to continuity_PPM_init. type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. @@ -1146,8 +1146,8 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt_in_T, elseif (theta > TwoPi) then theta = theta - TwoPi endif - cos_thetaDT = cos(theta)*dt_in_T - sin_thetaDT = sin(theta)*dt_in_T + cos_thetaDT = cos(theta)*dt + sin_thetaDT = sin(theta)*dt ! corner point coordinates of advected fluid parcel ---------- xg = x(I,J); yg = y(I,J) @@ -1345,7 +1345,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt_in_T, end subroutine propagate_corner_spread !> Propagates the internal wave energy in the logical x-direction. -subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt_in_T, G, US, Nangle, CS, LB) +subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1358,7 +1358,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt_in_T, G, US, Nangle, CS, LB real, dimension(Nangle), intent(in) :: Cgx_av !< The average x-projection in each angular band. real, dimension(Nangle), intent(in) :: dCgx !< The difference in x-projections between the !! edges of each angular band. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), pointer :: CS !< The control structure returned by a previous call !! to continuity_PPM_init. @@ -1392,13 +1392,13 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt_in_T, G, US, Nangle, CS, LB cg_p(I) = speed_x(I,j) * (Cgx_av(a)) enddo call zonal_flux_En(cg_p, En(:,j,a), EnL(:,j), EnR(:,j), flux1, & - dt_in_T, G, US, j, ish, ieh, CS%vol_CFL) + dt, G, US, j, ish, ieh, CS%vol_CFL) do I=ish-1,ieh ; flux_x(I,j) = flux1(I); enddo enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt_in_T*flux_x(I-1,j) ! left face influx (J) - Fdt_p(i,j,a) = -dt_in_T*flux_x(I,j) ! right face influx (J) + Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx (J) + Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx (J) enddo ; enddo enddo ! a-loop @@ -1420,7 +1420,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt_in_T, G, US, Nangle, CS, LB end subroutine propagate_x !> Propagates the internal wave energy in the logical y-direction. -subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt_in_T, G, US, Nangle, CS, LB) +subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1433,7 +1433,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt_in_T, G, US, Nangle, CS, LB real, dimension(Nangle), intent(in) :: Cgy_av !< The average y-projection in each angular band. real, dimension(Nangle), intent(in) :: dCgy !< The difference in y-projections between the !! edges of each angular band. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), pointer :: CS !< The control structure returned by a previous call !! to continuity_PPM_init. @@ -1468,13 +1468,13 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt_in_T, G, US, Nangle, CS, LB cg_p(i) = speed_y(i,J) * (Cgy_av(a)) enddo call merid_flux_En(cg_p, En(:,:,a), EnL(:,:), EnR(:,:), flux1, & - dt_in_T, G, US, J, ish, ieh, CS%vol_CFL) + dt, G, US, J, ish, ieh, CS%vol_CFL) do i=ish,ieh ; flux_y(i,J) = flux1(i); enddo enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt_in_T*flux_y(i,J-1) ! south face influx (J) - Fdt_p(i,j,a) = -dt_in_T*flux_y(i,J) ! north face influx (J) + Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx (J) + Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx (J) !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 46036175c7..2fc6934de4 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -395,13 +395,13 @@ end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity -subroutine calc_slope_functions(h, tv, dt_in_T, G, GV, US, CS) +subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & @@ -415,7 +415,7 @@ subroutine calc_slope_functions(h, tv, dt_in_T, G, GV, US, CS) if (CS%calculate_Eady_growth_rate) then call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then - call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_in_T*CS%kappa_smooth, & + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & CS%slope_x, CS%slope_y, N2_u, N2_v, 1) call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index d0a67aba77..3d1990df26 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -88,7 +88,7 @@ module MOM_mixed_layer_restrat !> Driver for the mixed-layer restratification parameterization. !! The code branches between two different implementations depending !! on whether the bulk-mixed layer or a general coordinate are in use. -subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt_in_T, MLD, VarMix, G, GV, US, CS) +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -99,7 +99,7 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt_in_T, MLD, VarMix, G !! [H L2 ~> 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_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the !! PBL scheme [H ~> m or kg m-2] type(VarMix_CS), pointer :: VarMix !< Container for derived fields @@ -109,15 +109,15 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt_in_T, MLD, VarMix, G "Module must be initialized before it is used.") if (GV%nkml>0) then - call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, CS) + call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) else - call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD, VarMix, G, GV, US, CS) + call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) endif end subroutine mixedlayer_restrat !> Calculates a restratifying flow in the mixed layer. -subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in, VarMix, G, GV, US, CS) +subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, US, CS) ! Arguments type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -129,7 +129,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in !! [H L2 ~> 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_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the !! PBL scheme [m] (not H) type(VarMix_CS), pointer :: VarMix !< Container for derived fields @@ -250,8 +250,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in 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_in_T + CS%MLE_MLD_decay_time ) - bFac = dt_in_T / ( dt_in_T + CS%MLE_MLD_decay_time ) + aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) + bFac = dt / ( dt + CS%MLE_MLD_decay_time ) do j = js-1, je+1 ; do i = is-1, ie+1 ! Expression bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered(i,j) is the time-filtered ! (running mean) of MLD. The max() allows the "running mean" to be reset @@ -267,8 +267,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in 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_in_T + CS%MLE_MLD_decay_time2 ) - bFac = dt_in_T / ( dt_in_T + CS%MLE_MLD_decay_time2 ) + aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) + bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) do j = js-1, je+1 ; do i = is-1, ie+1 ! Expression bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered(i,j) is the time-filtered ! (running mean) of MLD. The max() allows the "running mean" to be reset @@ -284,7 +284,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in uDml(:) = 0.0 ; vDml(:) = 0.0 uDml_slow(:) = 0.0 ; vDml_slow(:) = 0.0 - I4dt = 0.25 / (dt_in_T) + I4dt = 0.25 / dt g_Rho0 = GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z @@ -298,7 +298,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in p0(:) = 0.0 !$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt_in_T,vhml,vhtr, & +!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_LFront, & !$OMP res_upscale, & @@ -426,7 +426,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in enddo do k=1,nz uhml(I,j,k) = a(k)*uDml(I) + b(k)*uDml_slow(I) - uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt_in_T + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt enddo endif @@ -502,7 +502,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in enddo do k=1,nz vhml(i,J,k) = a(k)*vDml(i) + b(k)*vDml_slow(i) - vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt_in_T + vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt enddo endif @@ -512,7 +512,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie - h(i,j,k) = h(i,j,k) - dt_in_T*G%IareaT(i,j) * & + h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) enddo ; enddo ; enddo !$OMP end parallel @@ -559,7 +559,7 @@ end subroutine mixedlayer_restrat_general !> Calculates a restratifying flow assuming a 2-layer bulk mixed layer. -subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, CS) +subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -570,7 +570,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, !! [H L2 ~> 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_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -618,7 +618,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, if ((nkml<2) .or. (CS%ml_restrat_coef<=0.0)) return uDml(:) = 0.0 ; vDml(:) = 0.0 - I4dt = 0.25 / (dt_in_T) + I4dt = 0.25 / dt g_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff @@ -631,7 +631,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, p0(:) = 0.0 !$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail, & -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt_in_T,vhml,vhtr, & +!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP uDml_diag,vDml_diag,nkml) & !$OMP private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & @@ -699,7 +699,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, enddo do k=1,nkml uhml(I,j,k) = a(k)*uDml(I) - uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt_in_T + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k)*dt enddo endif @@ -745,7 +745,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, enddo do k=1,nkml vhml(i,J,k) = a(k)*vDml(i) - vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt_in_T + vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k)*dt enddo endif @@ -755,7 +755,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt_in_T, G, GV, US, !$OMP do do j=js,je ; do k=1,nkml ; do i=is,ie - h(i,j,k) = h(i,j,k) - dt_in_T*G%IareaT(i,j) * & + h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) enddo ; enddo ; enddo !$OMP end parallel diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 66f31ac9c6..3140d3a6c5 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -96,7 +96,7 @@ module MOM_thickness_diffuse !> Calculates thickness diffusion coefficients and applies thickness diffusion to layer !! thicknesses, h. Diffusivities are limited to ensure stability. !! Also returns along-layer mass fluxes used in the continuity equation. -subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt_in_T, G, GV, US, MEKE, VarMix, CDp, CS) +subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -106,7 +106,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt_in_T, G, GV, US, MEKE, VarMix real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux !! [L2 H ~> m3 or kg] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(MEKE_type), pointer :: MEKE !< MEKE control structure type(VarMix_CS), pointer :: VarMix !< Variable mixing coefficients type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation @@ -180,15 +180,15 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt_in_T, G, GV, US, MEKE, VarMix endif -!$OMP parallel do default(none) shared(is,ie,js,je,KH_u_CFL,dt_in_T,G,CS) +!$OMP parallel do default(none) shared(is,ie,js,je,KH_u_CFL,dt,G,CS) do j=js,je ; do I=is-1,ie KH_u_CFL(I,j) = (0.25*CS%max_Khth_CFL) / & - (dt_in_T * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) + (dt * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) enddo ; enddo -!$OMP parallel do default(none) shared(is,ie,js,je,KH_v_CFL,dt_in_T,G,CS) +!$OMP parallel do default(none) shared(is,ie,js,je,KH_v_CFL,dt,G,CS) do j=js-1,je ; do I=is,ie KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / & - (dt_in_T * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) + (dt * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) enddo ; enddo ! Calculates interface heights, e, in [Z ~> m]. @@ -382,7 +382,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt_in_T, G, GV, US, MEKE, VarMix !$OMP end parallel if (CS%detangle_interfaces) then - call add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt_in_T, G, GV, US, & + call add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, & CS, int_slope_u, int_slope_v) endif @@ -403,10 +403,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt_in_T, G, GV, US, MEKE, VarMix ! Calculate uhD, vhD from h, e, KH_u, KH_v, tv%T/S if (use_stored_slopes) then - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, G, GV, US, MEKE, CS, & + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) else - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, G, GV, US, MEKE, CS, & + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & int_slope_u, int_slope_v) endif @@ -475,18 +475,18 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt_in_T, G, GV, US, MEKE, VarMix endif - !$OMP parallel do default(none) shared(is,ie,js,je,nz,uhtr,uhD,dt_in_T,vhtr,CDp,vhD,h,G,GV) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,uhtr,uhD,dt,vhtr,CDp,vhD,h,G,GV) do k=1,nz do j=js,je ; do I=is-1,ie - uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) * dt_in_T + uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) * dt if (associated(CDp%uhGM)) CDp%uhGM(I,j,k) = uhD(I,j,k) enddo ; enddo do J=js-1,je ; do i=is,ie - vhtr(i,J,k) = vhtr(i,J,k) + vhD(i,J,k) * dt_in_T + vhtr(i,J,k) = vhtr(i,J,k) + vhD(i,J,k) * dt if (associated(CDp%vhGM)) CDp%vhGM(i,J,k) = vhD(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k) - dt_in_T * G%IareaT(i,j) * & + h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * & ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) if (h(i,j,k) < GV%Angstrom_H) h(i,j,k) = GV%Angstrom_H enddo ; enddo @@ -510,7 +510,7 @@ end subroutine thickness_diffuse !> Calculates parameterized layer transports for use in the continuity equation. !! Fluxes are limited to give positive definite thicknesses. !! Called by thickness_diffuse(). -subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, G, GV, US, MEKE, & +subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, & CS, int_slope_u, int_slope_v, slope_x, slope_y) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -527,7 +527,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vhD !< Meridional mass fluxes !! [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(:,:), pointer :: cg1 !< Wave speed [L T-1 ~> m s-1] - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(MEKE_type), pointer :: MEKE !< MEKE control structure type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_slope_u !< Ratio that determine how much of @@ -640,7 +640,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB - I4dt = 0.25 / (dt_in_T) + I4dt = 0.25 / dt I_slope_max2 = 1.0 / (CS%slope_max**2) G_scale = GV%g_Earth * GV%H_to_Z @@ -667,7 +667,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt_in_T, find_work = (associated(CS%GMwork) .or. find_work) if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt_in_T, T, S, G, GV, 1, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, 1, larger_h_denom=.true.) endif if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & @@ -1330,7 +1330,7 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) end subroutine streamfn_solver !> Modifies thickness diffusivities to untangle layer structures -subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt_in_T, G, GV, US, CS, & +subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, CS, & int_slope_u, int_slope_v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -1346,7 +1346,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt_in_T, real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity !! at v points [L2 T-1 ~> m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from @@ -1444,7 +1444,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt_in_T, ! distributing the diffusivities more effectively (with wt1 & wt2), but this ! means that the additions to a single interface can be up to twice as large. Kh_scale = 0.5 - if (CS%detangle_time > dt_in_T) Kh_scale = 0.5 * dt_in_T / CS%detangle_time + if (CS%detangle_time > dt) Kh_scale = 0.5 * dt / CS%detangle_time do j=js-1,je+1 ; do i=is-1,ie+1 de_top(i,j,k_top) = 0.0 ; de_bot(i,j) = 0.0 @@ -1493,7 +1493,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt_in_T, ! Limit the diffusivities - I_4t = Kh_scale / (4.0 * dt_in_T) + I_4t = Kh_scale / (4.0 * dt) do n=1,2 if (n==1) then ; jsh = js ; ish = is-1 diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index e09c46c616..2625867849 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -184,7 +184,7 @@ module MOM_bulk_mixed_layer !! For a traditional Kraus-Turner mixed layer, the values are: !! pen_SW_frac = 0.0, pen_SW_scale = 0.0 m, mstar = 1.25, !! nstar = 0.4, TKE_decay = 0.0, conv_decay = 0.0 -subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, US, CS, & +subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, CS, & optics, Hml, aggregate_FW_forcing, dt_diag, last_call) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -203,7 +203,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields !! have NULL ptrs. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to @@ -370,7 +370,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, if (CS%nkml > 1) Inkmlm1 = 1.0 / REAL(CS%nkml-1) Irho0 = 1.0 / (GV%Rho0) - dt__diag = dt_in_T ; if (present(dt_diag)) dt__diag = dt_diag + dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag Idt_diag = 1.0 / (dt__diag) write_diags = .true. ; if (present(last_call)) write_diags = last_call @@ -403,7 +403,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, ! Determine whether to zero out diagnostics before accumulation. reset_diags = .true. - if (present(dt_diag) .and. write_diags .and. (dt__diag > dt_in_T)) & + if (present(dt_diag) .and. write_diags .and. (dt__diag > dt)) & reset_diags = .false. ! This is the second call to mixedlayer. if (reset_diags) then @@ -530,7 +530,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, ! net_heat = heat via surface fluxes [degC H ~> degC m or degC kg m-2] ! net_salt = salt via surface fluxes [ppt H ~> dppt m or gSalt m-2] ! Pen_SW_bnd = components to penetrative shortwave radiation - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & CS%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) @@ -542,7 +542,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, & - dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt_in_T, & + dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt, & aggregate_FW_forcing) if (id_clock_conv>0) call cpu_clock_end(id_clock_conv) @@ -556,7 +556,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, if (id_clock_mech>0) call cpu_clock_begin(id_clock_mech) call find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt_in_T, Idt_diag, & + TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & j, ksort, G, GV, US, CS) ! Here the mechanically driven entrainment occurs. @@ -565,7 +565,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, cMKE, Idt_diag, nsw, Pen_SW_bnd, opacity_band, TKE, & Idecay_len_TKE, j, ksort, G, GV, US, CS) - call absorbRemainingSW(G, GV, US, h(:,1:), opacity_band, nsw, optics, j, dt_in_T, & + call absorbRemainingSW(G, GV, US, h(:,1:), opacity_band, nsw, optics, j, dt, & CS%H_limit_fluxes, CS%correct_absorption, CS%absorb_all_SW, & T(:,1:), Pen_SW_bnd, eps, ksort, htot, Ttot) @@ -639,11 +639,11 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt_in_T, ea, eb, G, GV, if (id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) if (CS%nkbl == 1) then call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & - GV%Rlay(:), dt_in_T, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & + GV%Rlay(:), dt, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & dRcv_dT, dRcv_dS, max_BL_det) elseif (CS%nkbl == 2) then call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & - GV%Rlay(:), dt_in_T, dt__diag, d_ea, j, G, GV, US, CS, & + GV%Rlay(:), dt, dt__diag, d_ea, j, G, GV, US, CS, & dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) else ! CS%nkbl not = 1 or 2 ! This code only works with 1 or 2 buffer layers. @@ -935,7 +935,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, & - dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt_in_T, & + dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt, & aggregate_FW_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. @@ -1016,7 +1016,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields !! have NULL ptrs. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are !! combined before being applied, instead of @@ -1066,7 +1066,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) - Idt = 1.0 / dt_in_T + Idt = 1.0 / dt is = G%isc ; ie = G%iec ; nz = GV%ke do i=is,ie ; if (ksort(i,1) > 0) then @@ -1303,7 +1303,7 @@ end subroutine mixedlayer_convection !> This subroutine determines the TKE available at the depth of free !! convection to drive mechanical entrainment. subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt_in_T, Idt_diag, & + TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1338,7 +1338,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, real, dimension(2,SZI_(G)), intent(out) :: cMKE !< Coefficients of HpE and HpE^2 in !! calculating the denominator of MKE_rate, !! [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. - real, intent(in) :: dt_in_T !< The time step [T ~> s]. + real, intent(in) :: dt !< The time step [T ~> s]. real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic !! time interval [T-1 ~> s-1]. integer, intent(in) :: j !< The j-index to work on. @@ -1371,7 +1371,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, integer :: is, ie, nz, i is = G%isc ; ie = G%iec ; nz = GV%ke - diag_wt = dt_in_T * Idt_diag + diag_wt = dt * Idt_diag if (CS%omega_frac >= 1.0) absf = 2.0*CS%omega do i=is,ie @@ -1402,7 +1402,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, ! scales contribute to mixed layer deepening at similar rates, even though ! small scales are dissipated more rapidly (implying they are less efficient). ! Ih = 1.0/(16.0*0.41*U_star*dt) - Ih = GV%H_to_Z/(3.0*0.41*U_star*dt_in_T) + Ih = GV%H_to_Z/(3.0*0.41*U_star*dt) cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = (absf_Ustar*GV%H_to_Z) * Ih if (Idecay_len_TKE(i) > 0.0) then @@ -1421,7 +1421,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (totEn_Z > 0.0) then nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt_in_T * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1431,7 +1431,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (Conv_En(i) > 0.0) then totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) ) nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt_in_T * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1439,7 +1439,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA) if (TKE_CA > 0.0) then nstar_CA = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt_in_T * (absf*(h_CA(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (absf*(h_CA(i)*GV%H_to_Z))**3 * totEn_Z)) else nstar_CA = CS%nstar endif @@ -1461,11 +1461,11 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, dKE_conv = dKE_CA(i,1) * MKE_rate_CA + dKE_FC(i) * MKE_rate_FC ! At this point, it is assumed that cTKE is positive and stored in TKE_CA! ! Note: Removed factor of 2 in u*^3 terms. - TKE(i) = (dt_in_T*CS%mstar)*((US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & + TKE(i) = (dt*CS%mstar)*((US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) if (CS%do_rivermix) then ! Add additional TKE at river mouths - TKE(i) = TKE(i) + TKE_river(i)*dt_in_T*exp_kh + TKE(i) = TKE(i) + TKE_river(i)*dt*exp_kh endif if (CS%TKE_diagnostics) then @@ -2201,7 +2201,7 @@ end subroutine resort_ML !> This subroutine moves any water left in the former mixed layers into the !! two buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea, j, G, GV, US, CS, & +subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -2215,7 +2215,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each !! layer [R ~> kg m-3]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. real, intent(in) :: dt_diag !< The diagnostic time step [T ~> s]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a layer in !! the entrainment from above @@ -2371,7 +2371,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea if (CS%nkbl /= 2) call MOM_error(FATAL, "MOM_mixed_layer"// & "CS%nkbl must be 2 in mixedlayer_detrain_2.") - if (dt_in_T < CS%BL_detrain_time) then ; dPE_time_ratio = CS%BL_detrain_time / (dt_in_T) + if (dt < CS%BL_detrain_time) then ; dPE_time_ratio = CS%BL_detrain_time / (dt) else ; dPE_time_ratio = 1.0 ; endif do i=is,ie @@ -3092,7 +3092,7 @@ end subroutine mixedlayer_detrain_2 !> This subroutine moves any water left in the former mixed layers into the !! single buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea, d_eb, & +subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & j, G, GV, US, CS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -3106,7 +3106,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each !! layer [R ~> kg m-3]. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. real, intent(in) :: dt_diag !< The accumulated time interval for !! diagnostics [T ~> s]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a layer in @@ -3159,7 +3159,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt_in_T, dt_diag, d_ea if (CS%nkbl /= 1) call MOM_error(FATAL,"MOM_mixed_layer: "// & "CS%nkbl must be 1 in mixedlayer_detrain_1.") - dt_Time = dt_in_T / CS%BL_detrain_time + dt_Time = dt / CS%BL_detrain_time g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0 * dt_diag) g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 4b94593715..3e2588db8c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -382,7 +382,7 @@ end subroutine adjust_salt !> Insert salt from brine rejection into the first layer below the mixed layer !! which both contains mass and in which the change in layer density remains !! stable after the addition of salt via brine rejection. -subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_lay) +subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) 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)), & @@ -394,7 +394,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_la integer, intent(in) :: nkmb !< The number of layers in the mixed and buffer layers type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous !! call to diabatic_aux_init - real, intent(in) :: dt_in_T !< The thermodynamic time step [T ~> s]. + real, intent(in) :: dt !< The thermodynamic time step [T ~> s]. integer, intent(in) :: id_brine_lay !< The handle for a diagnostic of !! which layer receivees the brine. @@ -432,7 +432,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt_in_T, id_brine_la salt(:)=0.0 ; dzbr(:)=0.0 do i=is,ie ; if (G%mask2dT(i,j) > 0.) then - salt(i) = dt_in_T * (1000. * fluxes%salt_flux(i,j)) + salt(i) = dt * (1000. * fluxes%salt_flux(i,j)) endif ; enddo do k=1,nz @@ -846,7 +846,7 @@ end subroutine diagnoseMLDbyDensityDifference !> Update the thickness, temperature, and salinity due to thermodynamic !! boundary forcing (contained in fluxes type) applied to h, tv%T and tv%S, !! and calculate the TKE implications of this heating. -subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, h, tv, & +subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, tv, & aggregate_FW_forcing, evap_CFL_limit, & minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & SkinBuoyFlux ) @@ -854,7 +854,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: dt_in_T !< Time-step over which forcing is applied [T ~> s] + real, intent(in) :: dt !< Time-step over which forcing is applied [T ~> s] type(forcing), intent(inout) :: fluxes !< Surface fluxes container type(optics_type), pointer :: optics !< Optical properties container integer, intent(in) :: nsw !< The number of frequency bands of penetrating @@ -945,7 +945,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, if (.not.associated(fluxes%sw)) return #define _OLD_ALG_ - Idt = 1.0 / dt_in_T + Idt = 1.0 / dt calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) @@ -974,7 +974,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,US,optics,fluxes, & !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & - !$OMP minimum_forcing_depth,evap_CFL_limit,dt_in_T, & + !$OMP minimum_forcing_depth,evap_CFL_limit,dt, & !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & @@ -1058,14 +1058,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! but do change answers. !----------------------------------------------------------------------------------------- if (calculate_buoyancy) then - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW, & net_Heat_rate=netheat_rate, net_salt_rate=netsalt_rate, & netmassinout_rate=netmassinout_rate, pen_sw_bnd_rate=pen_sw_bnd_rate) else - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h2d, T2d, netMassInOut, netMassOut, netHeat, netSalt, & Pen_SW_bnd, tv, aggregate_FW_forcing, nonpenSW=nonpenSW) @@ -1135,9 +1135,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (GV%Boussinesq) then - RivermixConst = -0.5*(CS%rivermix_depth*dt_in_T) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 else - RivermixConst = -0.5*(CS%rivermix_depth*dt_in_T) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) + RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) endif cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) @@ -1260,7 +1260,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, hGrounding(numberOfGroundings) = netMassIn(i)+netMassOut(i) endif !$OMP end critical - if (CS%id_createdH>0) CS%createdH(i,j) = CS%createdH(i,j) - (netMassIn(i)+netMassOut(i))/dt_in_T + if (CS%id_createdH>0) CS%createdH(i,j) = CS%createdH(i,j) - (netMassIn(i)+netMassOut(i))/dt endif enddo ! i @@ -1282,14 +1282,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, endif if (calculate_energetics) then - call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt_in_T, H_limit_fluxes, & + call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt, H_limit_fluxes, & .false., .true., T2d, Pen_SW_bnd, TKE=pen_TKE_2d, dSV_dT=dSV_dT_2d) k = 1 ! For setting break-points. do k=1,nz ; do i=is,ie cTKE(i,j,k) = cTKE(i,j,k) + pen_TKE_2d(i,k) enddo ; enddo else - call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt_in_T, H_limit_fluxes, & + call absorbRemainingSW(G, GV, US, h2d, opacityBand, nsw, optics, j, dt, H_limit_fluxes, & .false., .true., T2d, Pen_SW_bnd) endif @@ -1344,7 +1344,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt_in_T, fluxes, optics, nsw, ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, ! in which case the values of dt, h, optics and H_limit_fluxes are irrelevant. Consider ! writing a shorter and simpler variant to handle this very limited case. - ! call sumSWoverBands(G, GV, US, h2d(:,:), optics_nbands(optics), optics, j, dt_in_T, & + ! call sumSWoverBands(G, GV, US, h2d(:,:), optics_nbands(optics), optics, j, dt, & ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7f43067360..01f583292f 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -71,7 +71,7 @@ module MOM_int_tide_input contains !> Sets the model-state dependent internal tide energy sources. -subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt_in_T, G, GV, US, CS) +subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -83,7 +83,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt_in_T, G, GV, US, CS type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes type(int_tide_input_type), intent(inout) :: itide !< A structure containing fields related !! to the internal tide sources. - real, intent(in) :: dt_in_T !< The time increment [T ~> s]. + real, intent(in) :: dt !< The time increment [T ~> s]. type(int_tide_input_CS), pointer :: CS !< This module's control structure. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -109,7 +109,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt_in_T, G, GV, US, CS ! Smooth the properties through massless layers. if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt_in_T, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, larger_h_denom=.true.) endif call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index e358d66662..b4c100dc5d 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -200,7 +200,7 @@ module MOM_set_diffusivity !! viscosity associated with processes 1,2 and 4 listed above, which is stored in !! visc%Kv_slow. Vertical viscosity due to shear-driven mixing is passed via !! visc%Kv_shear -subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, & +subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & G, GV, US, CS, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -222,7 +222,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, !! properties of the ocean. type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properies, and related fields. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. @@ -280,7 +280,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, ! These hard-coded dimensional parameters are being replaced. kappa_dt_fill = US%m_to_Z**2 * 1.e-3 * 7200. else - kappa_dt_fill = CS%Kd_smooth * dt_in_T + kappa_dt_fill = CS%Kd_smooth * dt endif Omega2 = CS%omega * CS%omega @@ -353,7 +353,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, (GV%Z_to_H**2)*kappa_dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_adj, S_adj, tv, fluxes%p_surf, visc%Kd_shear, & - visc%TKE_turb, visc%Kv_shear_Bu, dt_in_T, G, GV, US, CS%kappaShear_CSp) + visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations if (CS%debug) then call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) @@ -363,7 +363,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, else ! Changes: visc%Kd_shear ; Sets: visc%Kv_shear and visc%TKE_turb call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & - visc%Kv_shear, dt_in_T, G, GV, US, CS%kappaShear_CSp) + visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) if (CS%debug) then call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=US%Z2_T_to_m2_s) @@ -465,7 +465,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt_in_T, endif endif - call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt_in_T, G, GV, US, CS, TKE_to_Kd, & + call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, TKE_to_Kd, & maxTKE, kb) if (associated(dd%maxTKE)) then ; do k=1,nz ; do i=is,ie dd%maxTKE(i,j,k) = maxTKE(i,k) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 830d159a29..64c519c8a8 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1002,7 +1002,7 @@ end function set_u_at_v !! A bulk Richardson criterion or the thickness of the topmost NKML layers (with a bulk mixed layer) !! are currently used. The thicknesses are given in terms of fractional layers, so that this !! thickness will move as the thickness of the topmost layers change. -subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, symmetrize) +subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetrize) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1018,7 +1018,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. - real, intent(in) :: dt_in_T !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(set_visc_CS), pointer :: CS !< The control structure returned by a previous !! call to vertvisc_init. logical, optional, intent(in) :: symmetrize !< If present and true, do extra calculations @@ -1141,7 +1141,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym OBC => CS%OBC use_EOS = associated(tv%eqn_of_state) - dt_Rho0 = dt_in_T / GV%H_to_RZ + dt_Rho0 = dt / GV%H_to_RZ h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (GV%Rho0) @@ -1193,7 +1193,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym endif enddo ; endif - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt_in_T,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & !$OMP h_neglect,h_tiny,g_H_Rho0,js,je,OBC,Isq,Ieq,nz, & !$OMP U_bg_sq,mask_v,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml) do j=js,je ! u-point loop @@ -1428,7 +1428,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt_in_T, G, GV, US, CS, sym enddo ! j-loop at u-points - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt_in_T,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & !$OMP h_neglect,h_tiny,g_H_Rho0,is,ie,OBC,Jsq,Jeq,nz, & !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml,mask_u) do J=Jsq,Jeq ! v-point loop diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index bf1c671028..be8ce41488 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -142,7 +142,7 @@ module MOM_vert_friction !! There is an additional stress term on the right-hand side !! if DIRECT_STRESS is true, applied to the surface layer. -subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS, & +subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & taux_bot, tauy_bot, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -155,7 +155,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure type(accel_diag_ptrs), intent(inout) :: ADp !< Accelerations in the momentum !! equations for diagnostics @@ -212,10 +212,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS Hmix = CS%Hmix_stress I_Hmix = 1.0 / Hmix endif - dt_Rho0 = dt_in_T / GV%H_to_RZ - dt_Z_to_H = dt_in_T*GV%Z_to_H + dt_Rho0 = dt / GV%H_to_RZ + dt_Z_to_H = dt*GV%Z_to_H h_neglect = GV%H_subroundoff - Idt = 1.0 / dt_in_T + Idt = 1.0 / dt !Check if Stokes mixing allowed if requested (present and associated) DoStokesMixing=.false. @@ -418,7 +418,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt_in_T, OBC, ADp, CDp, G, GV, US, CS enddo ! end of v-component J loop - call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, US, CS) + call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) ! Here the velocities associated with open boundary conditions are applied. if (associated(OBC)) then @@ -455,7 +455,7 @@ end subroutine vertvisc !! after a time-step of viscosity, and the fraction of a time-step's !! worth of barotropic acceleration that a layer experiences after !! viscosity is applied. -subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt_in_T, G, GV, US, CS) +subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag @@ -467,7 +467,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt_in_T, G, GV, US, CS intent(inout) :: visc_rem_v !< Fraction of a time-step's worth of a !! barotopic acceleration that a layer experiences after !! viscosity is applied in the meridional direction [nondim] - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure @@ -489,7 +489,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt_in_T, G, GV, US, CS if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") - dt_Z_to_H = dt_in_T*GV%Z_to_H + dt_Z_to_H = dt*GV%Z_to_H do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo @@ -563,7 +563,7 @@ end subroutine vertvisc_remnant !> Calculate the coupling coefficients (CS%a_u and CS%a_v) !! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the !! applying the implicit vertical viscosity via vertvisc(). -subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) +subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -575,7 +575,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure @@ -671,7 +671,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) endif !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & - !$OMP OBC,h_neglect,dt_in_T,I_valBL,Kv_u) & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_u) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo @@ -754,7 +754,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) endif call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt_in_T, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) + dt, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) if (allocated(hML_u)) then do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo endif @@ -769,7 +769,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) if (do_any_shelf) then if (CS%harmonic_visc) then call find_coupling_coef(a_shelf, hvel, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & visc, forces, work_on_u=.true., OBC=OBC, shelf=.true.) else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. @@ -797,7 +797,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) endif ; enddo enddo call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, & + bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & visc, forces, work_on_u=.true., OBC=OBC, shelf=.true.) endif do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo @@ -838,7 +838,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) ! Now work on v-points. !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & - !$OMP OBC,h_neglect,dt_in_T,I_valBL,Kv_v) & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_v) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo @@ -923,7 +923,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) endif call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt_in_T, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) + dt, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) if ( allocated(hML_v)) then do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo endif @@ -937,7 +937,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) if (do_any_shelf) then if (CS%harmonic_visc) then call find_coupling_coef(a_shelf, hvel, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, visc, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, & forces, work_on_u=.false., OBC=OBC, shelf=.true.) else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. @@ -965,7 +965,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt_in_T, G, GV, US, CS, OBC) endif ; enddo enddo call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt_in_T, j, G, GV, US, CS, & + bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & visc, forces, work_on_u=.false., OBC=OBC, shelf=.true.) endif do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo @@ -1030,7 +1030,7 @@ end subroutine vertvisc_coef !! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent !! layer thicknesses are used to calculate a_cpl near the bottom. subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt_in_T, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) + dt, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1050,7 +1050,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, !! normalized by the bottom boundary layer thickness real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [H ~> m or kg m-2] integer, intent(in) :: j !< j-index to find coupling coefficient for - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces @@ -1103,7 +1103,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! The maximum coupling coefficent was originally introduced to avoid ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 ! sets the maximum coupling coefficient increment to 1e10 m per timestep. - I_amax = (1.0e-10*US%Z_to_m) * dt_in_T + I_amax = (1.0e-10*US%Z_to_m) * dt do_shelf = .false. ; if (present(shelf)) do_shelf = shelf do_OBCs = .false. @@ -1303,7 +1303,7 @@ end subroutine find_coupling_coef !> Velocity components which exceed a threshold for physically reasonable values !! are truncated. Optionally, any column with excessive velocities may be sent !! to a diagnostic reporting subroutine. -subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, US, CS) +subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1317,7 +1317,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U type(cont_diag_ptrs), intent(in) :: CDp !< Continuity diagnostic pointers type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt_in_T !< Time increment [T ~> s] + real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! Local variables @@ -1338,7 +1338,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U maxvel = CS%maxvel truncvel = 0.9*maxvel H_report = 6.0 * GV%Angstrom_H - dt_Rho0 = (US%L_T_to_m_s*US%Z_to_m) * dt_in_T / (GV%Rho0) + dt_Rho0 = (US%L_T_to_m_s*US%Z_to_m) * dt / (GV%Rho0) if (len_trim(CS%u_trunc_file) > 0) then !$OMP parallel do default(shared) private(trunc_any,CFL) @@ -1350,9 +1350,9 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U 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_in_T) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) + CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else - CFL = (u(I,j,k) * dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i,j)) + CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) endif if (CFL > CS%CFL_trunc) trunc_any = .true. if (CFL > CS%CFL_report) then @@ -1376,11 +1376,11 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U if (trunc_any) then ; if (CS%CFL_based_trunc) then do k=1,nz ; do I=Isq,Ieq - if ((u(I,j,k) * (dt_in_T * 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_in_T * G%dy_Cu(I,j))) + if ((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_in_T * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then - u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt_in_T * G%dy_Cu(I,j))) + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo @@ -1393,14 +1393,14 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U enddo ! j-loop 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_in_T,G,CS,h,H_report) +!$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 (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 - elseif ((u(I,j,k) * (dt_in_T * 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_in_T * G%dy_Cu(I,j))) + 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_in_T * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then - u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt_in_T * G%dy_Cu(I,j))) + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo ; enddo @@ -1420,7 +1420,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U do j=js,je; do I=Isq,Ieq ; if (dowrite(I,j)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. - call write_u_accel(I, j, u_old, h, ADp, CDp, dt_in_T, G, GV, US, CS%PointAccel_CSp, & + call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & vel_report(I,j), forces%taux(I,j)*dt_Rho0, a=CS%a_u, hv=CS%h_u) endif ; enddo ; enddo endif @@ -1435,9 +1435,9 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U 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_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) + CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else - CFL = (v(i,J,k) * dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) endif if (CFL > CS%CFL_trunc) trunc_any = .true. if (CFL > CS%CFL_report) then @@ -1461,11 +1461,11 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U if (trunc_any) then ; if (CS%CFL_based_trunc) then do k=1,nz; do i=is,ie - if ((v(i,J,k) * (dt_in_T * 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_in_T * G%dx_Cv(i,J))) + if ((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_in_T * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then - v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt_in_T * G%dx_Cv(i,J))) + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo @@ -1481,11 +1481,11 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U !$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 ((v(i,J,k) * (dt_in_T * 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_in_T * G%dx_Cv(i,J))) + 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_in_T * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then - v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt_in_T * G%dx_Cv(i,J))) + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo ; enddo @@ -1505,7 +1505,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt_in_T, G, GV, U do J=Jsq,Jeq; do i=is,ie ; if (dowrite(i,J)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. - call write_v_accel(i, J, v_old, h, ADp, CDp, dt_in_T, G, GV, US, CS%PointAccel_CSp, & + call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & vel_report(i,J), forces%tauy(i,J)*dt_Rho0, a=CS%a_v, hv=CS%h_v) endif ; enddo ; enddo endif From 41c860a90dc9e066b03effddfdbb5bd5a42d2351 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 16:49:24 -0400 Subject: [PATCH 195/259] +Rescaled advective and diffusive tracer diags Rescaled the time units of advective and diffusive tracer diagnostics. Also renamed the internal variable dt to dt_in_s and dt_in_T to dt in MOM_tracer_hor_diff.F90. All answers are bitwise identical. --- src/tracer/MOM_tracer_advect.F90 | 12 +++----- src/tracer/MOM_tracer_hor_diff.F90 | 49 +++++++++++++++--------------- src/tracer/MOM_tracer_registry.F90 | 42 ++++++++++++------------- 3 files changed, 49 insertions(+), 54 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 753faa2a56..23730b59dd 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -88,7 +88,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! can be simply discarded [H L2 ~> m3 or kg]. real :: landvolfill ! An arbitrary? nonzero cell volume [H L2 ~> m3 or kg]. - real :: Idt ! 1/dt [s-1]. + real :: Idt ! 1/dt [T-1 ~> s-1]. logical :: domore_u(SZJ_(G),SZK_(G)) ! domore__ indicate whether there is more logical :: domore_v(SZJB_(G),SZK_(G)) ! advection to be done in the corresponding ! row or column. @@ -122,7 +122,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ntr = Reg%ntr do m=1,ntr ; Tr(m) = Reg%Tr(m) ; enddo - Idt = 1.0/dt + Idt = 1.0 / (US%s_to_T*dt) max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 @@ -339,7 +339,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u !< If true, there is more advection to be !! done in this u-row - real, intent(in) :: Idt !< The inverse of dt [s-1] + real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] integer, intent(in) :: ntr !< The number of tracers integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on @@ -380,7 +380,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 real :: fac1,u_L_in,u_L_out ! terms used for time-stepping OBC reservoirs type(OBC_segment_type), pointer :: segment=>NULL() - real :: dt ! the inverse of Idt, needed for time-stepping of tracer reservoirs logical :: usePLMslope usePLMslope = .not. (usePPM .and. useHuynh) @@ -390,7 +389,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & min_h = 0.1*GV%Angstrom_H h_neglect = GV%H_subroundoff - dt=1.0/Idt ! do I=is-1,ie ; ts2(I) = 0.0 ; enddo do I=is-1,ie ; CFL(I) = 0.0 ; enddo @@ -696,7 +694,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used logical, dimension(SZJB_(G),SZK_(G)), intent(inout) :: domore_v !< If true, there is more advection to be !! done in this v-row - real, intent(in) :: Idt !< The inverse of dt [s-1] + real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] integer, intent(in) :: ntr !< The number of tracers integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on @@ -736,7 +734,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & integer :: i, j, j2, m, n, j_up, stencil real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 real :: fac1,v_L_in,v_L_out ! terms used for time-stepping OBC reservoirs - real :: dt ! The inverse of Idt, needed for segment reservoir time-stepping type(OBC_segment_type), pointer :: segment=>NULL() logical :: usePLMslope @@ -747,7 +744,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & min_h = 0.1*GV%Angstrom_H h_neglect = GV%H_subroundoff - dt=1.0/Idt !do i=is,ie ; ts2(i) = 0.0 ; enddo ! We conditionally perform work on tracer points: calculating the PLM slope, diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index ecc8074169..9e4dc735c9 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -35,11 +35,10 @@ module MOM_tracer_hor_diff !> The ocntrol structure for along-layer and epineutral tracer diffusion type, public :: tracer_hor_diff_CS ; private - real :: dt !< The baroclinic dynamics time step [s]. - real :: KhTr !< The along-isopycnal tracer diffusivity [m2 s-1]. - real :: KhTr_Slope_Cff !< The non-dimensional coefficient in KhTr formula - real :: KhTr_min !< Minimum along-isopycnal tracer diffusivity [m2 s-1]. - real :: KhTr_max !< Maximum along-isopycnal tracer diffusivity [m2 s-1]. + real :: KhTr !< The along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. + real :: KhTr_Slope_Cff !< The non-dimensional coefficient in KhTr formula [nondim] + real :: KhTr_min !< Minimum along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. + real :: KhTr_max !< Maximum along-isopycnal tracer diffusivity [L2 T-1 ~> m2 s-1]. real :: KhTr_passivity_coeff !< Passivity coefficient that scales Rd/dx (default = 0) !! where passivity is the ratio between along-isopycnal !! tracer mixing and thickness mixing [nondim] @@ -97,11 +96,11 @@ module MOM_tracer_hor_diff !! using the diffusivity in CS%KhTr, or using space-dependent diffusivity. !! Multiple iterations are used (if necessary) so that there is no limit !! on the acceptable time increment. -subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) +subroutine tracer_hordiff(h, dt_in_s, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) type(ocean_grid_type), intent(inout) :: G !< Grid type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt_in_s !< time step [s] type(MEKE_type), pointer :: MEKE !< MEKE type type(VarMix_CS), pointer :: VarMix !< Variable mixing type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -153,11 +152,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online 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 ! layer for this iteration [nondim]. - real :: Idt ! The inverse of the time step [s-1]. + real :: Idt ! The inverse of the time step [T-1 ~> s-1]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: Kh_loc ! The local value of Kh [L2 T-1 ~> m2 s-1]. - real :: dt_in_T ! The timestep [T ~> s] + real :: dt ! The timestep [T ~> s] real :: Res_Fn ! The local value of the resolution function [nondim]. real :: Rd_dx ! The local value of deformation radius over grid-spacing [nondim]. real :: normalize ! normalization used for diagnostic Kh_h; diffusivity averaged to h-points. @@ -178,8 +177,8 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call cpu_clock_begin(id_clock_diffuse) ntr = Reg%ntr - dt_in_T = US%s_to_T*dt - Idt = 1.0/dt + dt = US%s_to_T*dt_in_s + Idt = 1.0 / dt h_neglect = GV%H_subroundoff if (CS%Diffuse_ML_interior .and. CS%first_call) then ; if (is_root_pe()) then @@ -248,48 +247,48 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = dt_in_T*(Kh_u(I,j)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + khdt_x(I,j) = dt*(Kh_u(I,j)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - khdt_y(i,J) = dt_in_T*(Kh_v(i,J)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + khdt_y(i,J) = dt*(Kh_v(i,J)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo elseif (Resoln_scaled) then !$OMP parallel do default(shared) private(Res_fn) do j=js,je ; do I=is-1,ie Res_fn = 0.5 * (VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) Kh_u(I,j) = max(CS%KhTr * Res_fn, CS%KhTr_min) - khdt_x(I,j) = dt_in_T*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn enddo ; enddo !$OMP parallel do default(shared) private(Res_fn) do J=js-1,je ; do i=is,ie Res_fn = 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) Kh_v(i,J) = max(CS%KhTr * Res_fn, CS%KhTr_min) - khdt_y(i,J) = dt_in_T*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn enddo ; enddo else ! Use a simple constant diffusivity. if (CS%id_KhTr_u > 0) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie Kh_u(I,j) = CS%KhTr - khdt_x(I,j) = dt_in_T*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = dt_in_T*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo endif if (CS%id_KhTr_v > 0) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie Kh_v(i,J) = CS%KhTr - khdt_y(i,J) = dt_in_T*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo else !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - khdt_y(i,J) = dt_in_T*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo endif endif ! VarMix @@ -302,7 +301,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_x(I,j) > khdt_max) then khdt_x(I,j) = khdt_max if (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j)) > 0.0) & - Kh_u(I,j) = khdt_x(I,j) / (dt_in_T*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + Kh_u(I,j) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) endif enddo ; enddo else @@ -319,7 +318,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_y(i,J) > khdt_max) then khdt_y(i,J) = khdt_max if (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J)) > 0.0) & - Kh_v(i,J) = khdt_y(i,J) / (dt_in_T*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + Kh_v(i,J) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) endif enddo ; enddo else @@ -410,7 +409,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call neutral_diffusion_calc_coeffs(G, GV, h, tv%T, tv%S, CS%neutral_diffusion_CSp) endif endif - call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, US, CS%neutral_diffusion_CSp) + call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*US%T_to_s*dt, Reg, US, CS%neutral_diffusion_CSp) enddo ! itt else ! following if not using neutral diffusion, but instead along-surface diffusion @@ -550,7 +549,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & 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(in) :: h !< layer thickness [H ~> m or kg m-2] - real, intent(in) :: dt !< time step + real, intent(in) :: dt !< time step [T ~> s] type(tracer_type), intent(inout) :: Tr(:) !< tracer array integer, intent(in) :: ntr !< number of tracers real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: khdt_epi_x !< Zonal epipycnal diffusivity times @@ -623,7 +622,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & nPv ! The number of epipycnal pairings at each v-point. real :: h_exclude ! A thickness that layers must attain to be considered ! for inclusion in mixing [H ~> m or kg m-2]. - real :: Idt ! The inverse of the time step [s-1]. + real :: Idt ! The inverse of the time step [T-1 ~> s-1]. real :: I_maxitt ! The inverse of the maximum number of iterations. real :: rho_pair, rho_a, rho_b ! Temporary densities [R ~> kg m-3]. real :: Tr_min_face ! The minimum and maximum tracer concentrations @@ -654,7 +653,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & 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 - Idt = 1.0/dt + Idt = 1.0 / dt nkmb = GV%nk_rho_varies if (num_itts <= 1) then diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 6a2dd79b5b..ce9ea4285b 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -393,33 +393,33 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & - conversion=Tr%flux_scale) + conversion=Tr%flux_scale*US%s_to_T) Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & - conversion=Tr%flux_scale) + conversion=Tr%flux_scale*US%s_to_T) Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & - conversion=(US%L_to_m**2)*Tr%flux_scale) + conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_dfy = register_diag_field("ocean_model", trim(shortnm)//"_dfy", & diag%axesCvL, Time, trim(flux_longname)//" diffusive zonal flux" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & - conversion=(US%L_to_m**2)*Tr%flux_scale) + conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) 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, y_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*US%s_to_T, 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, x_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*US%s_to_T, 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=(US%L_to_m**2)*Tr%flux_scale, & + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & 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=(US%L_to_m**2)*Tr%flux_scale, & + flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') endif if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) @@ -430,20 +430,20 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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, y_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*US%s_to_T, 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, x_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*US%s_to_T, 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=(US%L_to_m**2)*Tr%flux_scale, & + flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & 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=(US%L_to_m**2)*Tr%flux_scale, & + flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) @@ -455,11 +455,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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*US%s_to_T) 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*US%s_to_T) 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) @@ -658,14 +658,14 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) 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, alt_h = diag_prev%h_state) + call post_data(Tr%id_tendency, work3d, diag, alt_h=diag_prev%h_state) 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, alt_h = diag_prev%h_state) + if (Tr%id_trxh_tendency > 0) call post_data(Tr%id_trxh_tendency, work3d, diag, alt_h=diag_prev%h_state) if (Tr%id_trxh_tendency_2d > 0) then work2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie @@ -697,15 +697,15 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) 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) - if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h = h_diag) - if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h = h_diag) - if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h = h_diag) - if (Tr%id_dfy > 0) call post_data(Tr%id_dfy, Tr%df_y, diag, alt_h = h_diag) + if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h=h_diag) + if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h=h_diag) + if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h=h_diag) + if (Tr%id_dfy > 0) call post_data(Tr%id_dfy, Tr%df_y, diag, alt_h=h_diag) if (Tr%id_adx_2d > 0) call post_data(Tr%id_adx_2d, Tr%ad2d_x, diag) if (Tr%id_ady_2d > 0) call post_data(Tr%id_ady_2d, Tr%ad2d_y, diag) if (Tr%id_dfx_2d > 0) call post_data(Tr%id_dfx_2d, Tr%df2d_x, diag) if (Tr%id_dfy_2d > 0) call post_data(Tr%id_dfy_2d, Tr%df2d_y, diag) - if (Tr%id_adv_xy > 0) call post_data(Tr%id_adv_xy, Tr%advection_xy, diag, alt_h = h_diag) + if (Tr%id_adv_xy > 0) call post_data(Tr%id_adv_xy, Tr%advection_xy, diag, alt_h=h_diag) if (Tr%id_adv_xy_2d > 0) then work2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie From 2cd827625a3ae3e02cbf09d56132201836ede235 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 16:50:07 -0400 Subject: [PATCH 196/259] Clarified comments in MOM_tracer_diabatic Modified comments to clarify the options for the units of arguments to tracer_vertdiff. Only comments have changed, and all answers are bitwise identical. --- src/tracer/MOM_tracer_diabatic.F90 | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index f7f8028d91..276742905c 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -18,10 +18,10 @@ module MOM_tracer_diabatic contains -!> This subroutine solves a tridiagonal equation for the final tracer -!! concentrations after the dual-entrainments, and possibly sinking or surface -!! and bottom sources, are applied. The sinking is implemented with an -!! fully implicit upwind advection scheme. +!> This subroutine solves a tridiagonal equation for the final tracer concentrations after the +!! dual-entrainments, and possibly sinking or surface and bottom sources, are applied. The sinking +!! is implemented with an fully implicit upwind advection scheme. Alternate time units can be +!! used for the timestep, surface and bottom fluxes and sink_rate provided they are all consistent. subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & sfc_flux, btm_flux, btm_reservoir, sink_rate, convert_flux_in) type(ocean_grid_type), intent(in) :: G !< ocean grid structure @@ -33,13 +33,18 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< amount of fluid entrained from the layer !! below [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: tr !< tracer concentration in concentration units [CU] - real, intent(in) :: dt !< amount of time covered by this call [s] - real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer [CU kg m-2 s-1] + real, intent(in) :: dt !< amount of time covered by this call [T ~> s] + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer in units of + !! [CU kg m-2 T-1 ~> CU kg m-2 s-1] or + !! [CU H ~> CU m or CU kg m-2] if + !! convert_flux_in is .false. real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: btm_flux !< The (negative upward) bottom flux of the - !! tracer [CU kg m-2 s-1] + !! tracer in [CU kg m-2 T-1 ~> CU kg m-2 s-1] or + !! [CU H ~> CU m or CU kg m-2] if real, dimension(SZI_(G),SZJ_(G)), optional,intent(inout) :: btm_reservoir !< amount of tracer in a bottom reservoir !! [CU kg m-2]; formerly [CU m] - real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks [m s-1] + real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks + !! [m T-1 ~> m s-1] logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs !! to be integrated in time From 88fcb8adfd555794d25688e5e24e069f17e88e12 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 17:49:51 -0400 Subject: [PATCH 197/259] +Rescaled timestep arguments to several routines Pass timesteps to step_MOM_dyn_split, step_MOM_dyn_split_RK2, step_MOM_dyn_unsplit, diabatic, advect_tracer and tracer_hordiff in units of [T]. Also corrected some comments. All answers are bitwise identical, but the units of some arguments have been rescaled. --- src/core/MOM.F90 | 42 +++++++++---------- src/core/MOM_continuity_PPM.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 13 +++--- src/core/MOM_dynamics_unsplit.F90 | 6 +-- src/core/MOM_dynamics_unsplit_RK2.F90 | 6 +-- .../vertical/MOM_diabatic_driver.F90 | 6 +-- src/tracer/MOM_tracer_advect.F90 | 9 ++-- src/tracer/MOM_tracer_hor_diff.F90 | 6 +-- 8 files changed, 40 insertions(+), 50 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0895ad6da8..4d18941419 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -867,7 +867,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & end subroutine step_MOM !> Time step the ocean dynamics, including the momentum and continuity equations -subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & +subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_thermo, & bbl_time_int, CS, Time_local, Waves) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface @@ -876,7 +876,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface !! pressure at the end of this dynamic step, !! intent in [Pa]. - real, intent(in) :: dt !< time interval covered by this call [s]. + real, intent(in) :: dt_in_s !< time interval covered by this call [s]. real, intent(in) :: dt_thermo !< time interval covered by any updates that may !! span multiple dynamics steps [s]. real, intent(in) :: bbl_time_int !< time interval over which updates to the @@ -917,11 +917,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & showCallTree = callTree_showQuery() call cpu_clock_begin(id_clock_dynamics) - dt_in_T = US%s_to_T*dt + dt_in_T = US%s_to_T*dt_in_s if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then - call enable_averaging(dt_thermo, Time_local+real_to_time(dt_thermo-dt), CS%diag) + call enable_averaging(dt_thermo, Time_local+real_to_time(dt_thermo-dt_in_s), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & call calc_slope_functions(h, CS%tv, dt_in_T, G, GV, US, CS%VarMix) @@ -940,7 +940,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! The bottom boundary layer properties need to be recalculated. if (bbl_time_int > 0.0) then call enable_averaging(bbl_time_int, & - Time_local + real_to_time(bbl_time_int-dt), CS%diag) + Time_local + real_to_time(bbl_time_int-dt_in_s), CS%diag) ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) call set_viscous_BBL(CS%u(:,:,:), CS%v(:,:,:), CS%h, CS%tv, CS%visc, G, GV, US, & @@ -964,7 +964,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif endif - call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt_in_T, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & CS%MEKE, CS%thickness_diffuse_CSp, waves=waves) @@ -979,11 +979,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! 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, & + call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt_in_T, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, 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, & + call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt_in_T, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, Waves=Waves) endif @@ -1035,15 +1035,15 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call disable_averaging(CS%diag) ! Advance the dynamics time by dt. - CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt - CS%t_dyn_rel_thermo = CS%t_dyn_rel_thermo + dt - if (abs(CS%t_dyn_rel_thermo) < 1e-6*dt) CS%t_dyn_rel_thermo = 0.0 - CS%t_dyn_rel_diag = CS%t_dyn_rel_diag + dt + CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt_in_s + CS%t_dyn_rel_thermo = CS%t_dyn_rel_thermo + dt_in_s + if (abs(CS%t_dyn_rel_thermo) < 1e-6*dt_in_s) CS%t_dyn_rel_thermo = 0.0 + CS%t_dyn_rel_diag = CS%t_dyn_rel_diag + dt_in_s call cpu_clock_end(id_clock_dynamics) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) - call enable_averaging(dt, Time_local, CS%diag) + call enable_averaging(dt_in_s, Time_local, CS%diag) ! These diagnostics are available after every time dynamics step. 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) @@ -1087,9 +1087,9 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) 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, US, & + call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, US%s_to_T*CS%t_dyn_rel_adv, G, GV, US, & CS%tracer_adv_CSp, CS%tracer_Reg) - call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h, US%s_to_T*CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & @@ -1194,7 +1194,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & - dtdia, Time_end_thermo, G, GV, US, CS%diabatic_CSp, Waves=Waves) + US%s_to_T*dtdia, Time_end_thermo, G, GV, US, CS%diabatic_CSp, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -1407,7 +1407,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, US%s_to_T*REAL(dt_offline), G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, US%s_to_T*REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1432,7 +1432,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, US%s_to_T*REAL(dt_offline), G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, US%s_to_T*REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1467,7 +1467,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS CS%h, eatr, ebtr, uhtr, vhtr) ! Perform offline diffusion if requested if (.not. skip_diffusion) then - call tracer_hordiff(h_end, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h_end, US%s_to_T*REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif @@ -2301,7 +2301,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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, & G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & - CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & + US%s_to_T*CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt) @@ -2362,7 +2362,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%sponge_CSp, CS%ALE_sponge_CSp) endif - call tracer_advect_init(Time, G, param_file, diag, CS%tracer_adv_CSp) + call tracer_advect_init(Time, G, US, param_file, diag, CS%tracer_adv_CSp) call tracer_hor_diff_init(Time, G, US, param_file, diag, CS%tv%eqn_of_state, & CS%tracer_diff_CSp) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 24c5bf7def..96fa98cbf3 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -867,7 +867,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, !! value of du [L T-1 ~> m s-1]. real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable !! value of du [L T-1 ~> m s-1]. - real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), pointer :: CS !< This module's control structure. real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index bbda47925b..43e2684f45 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -233,7 +233,7 @@ module MOM_dynamics_split_RK2 !> RK2 splitting for time stepping MOM adiabatic dynamics subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & - Time_local, dt_in_s, forces, p_surf_begin, p_surf_end, & + Time_local, dt, forces, p_surf_begin, p_surf_end, & uh, vh, uhtr, vhtr, eta_av, & G, GV, US, CS, calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure @@ -248,7 +248,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic type type(vertvisc_type), intent(inout) :: visc !< vertical visc, bottom drag, and related type(time_type), intent(in) :: Time_local !< model time at end of time step - real, intent(in) :: dt_in_s !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at start of this dynamic !! time step [Pa] @@ -317,7 +317,6 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. - real :: dt ! The dynamics time step [T ~> s] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -333,8 +332,6 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta - dt = US%s_to_T*dt_in_s - sym=.false.;if (G%Domain%symmetric) sym=.true. ! switch to include symmetric domain in checksums showCallTree = callTree_showQuery() @@ -954,7 +951,7 @@ end subroutine register_restarts_dyn_split_RK2 !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & - diag, CS, restart_CS, dt_in_s, Accel_diag, Cont_diag, MIS, & + diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & visc, dirs, ntrunc, calc_dtbt) @@ -976,7 +973,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure type(MOM_restart_CS), pointer :: restart_CS !< restart control structure - real, intent(in) :: dt_in_s !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for !! budget analysis type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation @@ -1178,7 +1175,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(uh,"uh",restart_CS) .or. & .not. query_initialized(vh,"vh",restart_CS)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo - call continuity(u, v, h, h_tmp, uh, vh, US%s_to_T*dt_in_s, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) + call continuity(u, v, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) do k=1,nz ; do j=jsd,jed ; do i=isd,ied CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index c0725de4df..5f06b082e1 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -182,7 +182,7 @@ module MOM_dynamics_unsplit !> Step the MOM6 dynamics using an unsplit mixed 2nd order (for continuity) and !! 3rd order (for the inviscid momentum equations) order scheme -subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt_in_s, forces, & +subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & VarMix, MEKE, Waves) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -197,7 +197,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt_in_s, forces, !! viscosities, bottom drag viscosities, and related fields. type(time_type), intent(in) :: Time_local !< The model time at the end !! of the time step. - real, intent(in) :: dt_in_s !< The dynamics time step [s]. + real, intent(in) :: dt !< The dynamics time step [T ~> s]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface !! pressure at the start of this dynamic step [Pa]. @@ -227,13 +227,11 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt_in_s, forces, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up, upp ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() - real :: dt ! The dynamics time step [T ~> s] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz 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 - dt = US%s_to_T*dt_in_s dt_pred = dt / 3.0 h_av(:,:,:) = 0; hp(:,:,:) = 0 diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 6adb6469a7..3d4f8777bc 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -185,7 +185,7 @@ module MOM_dynamics_unsplit_RK2 ! ============================================================================= !> Step the MOM6 dynamics using an unsplit quasi-2nd order Runge-Kutta scheme -subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt_in_s, forces, & +subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & VarMix, MEKE) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -205,7 +205,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt_i !! viscosities, and related fields. type(time_type), intent(in) :: Time_local !< The model time at the end of !! the time step. - real, intent(in) :: dt_in_s !< The baroclinic dynamics time step [s]. + real, intent(in) :: dt !< The baroclinic dynamics time step [T ~> s]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to !! the surface pressure at the beginning @@ -238,14 +238,12 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt_i real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() - real :: dt ! The dynamics time step [T ~> s] real :: dt_pred ! The time step for the predictor part of the baroclinic ! time stepping [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz 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 - dt = US%s_to_T*dt_in_s dt_pred = dt * CS%BE h_av(:,:,:) = 0; hp(:,:,:) = 0 diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 4587949e30..ff7da9e870 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -254,7 +254,7 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt_in_s, Time_end, & +subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -272,7 +272,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt_in_s, Time_end, !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt_in_s !< time increment [s] + real, intent(in) :: dt !< time increment [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves @@ -283,14 +283,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt_in_s, Time_end, real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn_IGW ! baroclinic internal gravity wave speeds real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp - real :: dt ! The time step converted to T units [T ~> s] integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree if (G%ke == 1) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - dt = dt_in_s * US%s_to_T if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "Module must be initialized before it is used.") diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 23730b59dd..b4b055ddbe 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -58,7 +58,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: vhtr !< accumulated volume/mass flux through merid face [H L2 ~> m3 or kg] type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used - real, intent(in) :: dt !< time increment [s] + real, intent(in) :: dt !< time increment [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_advect_CS), pointer :: CS !< control structure for module type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry @@ -122,7 +122,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ntr = Reg%ntr do m=1,ntr ; Tr(m) = Reg%Tr(m) ; enddo - Idt = 1.0 / (US%s_to_T*dt) + Idt = 1.0 / dt max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 @@ -1047,9 +1047,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & end subroutine advect_y !> Initialize lateral tracer advection module -subroutine tracer_advect_init(Time, G, param_file, diag, CS) +subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output type(tracer_advect_CS), pointer :: CS !< module control structure @@ -1072,7 +1073,7 @@ subroutine tracer_advect_init(Time, G, param_file, diag, 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, "DT", CS%dt, fail_if_missing=.true., & - desc="The (baroclinic) dynamics time step.", units="s") + desc="The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "TRACER_ADVECTION_SCHEME", mesg, & desc="The horizontal transport scheme for tracers:\n"//& diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 9e4dc735c9..5e0e0ae600 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -96,11 +96,11 @@ module MOM_tracer_hor_diff !! using the diffusivity in CS%KhTr, or using space-dependent diffusivity. !! Multiple iterations are used (if necessary) so that there is no limit !! on the acceptable time increment. -subroutine tracer_hordiff(h, dt_in_s, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) +subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) type(ocean_grid_type), intent(inout) :: G !< Grid type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, intent(in) :: dt_in_s !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] type(MEKE_type), pointer :: MEKE !< MEKE type type(VarMix_CS), pointer :: VarMix !< Variable mixing type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -156,7 +156,6 @@ subroutine tracer_hordiff(h, dt_in_s, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_o real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: Kh_loc ! The local value of Kh [L2 T-1 ~> m2 s-1]. - real :: dt ! The timestep [T ~> s] real :: Res_Fn ! The local value of the resolution function [nondim]. real :: Rd_dx ! The local value of deformation radius over grid-spacing [nondim]. real :: normalize ! normalization used for diagnostic Kh_h; diffusivity averaged to h-points. @@ -177,7 +176,6 @@ subroutine tracer_hordiff(h, dt_in_s, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_o call cpu_clock_begin(id_clock_diffuse) ntr = Reg%ntr - dt = US%s_to_T*dt_in_s Idt = 1.0 / dt h_neglect = GV%H_subroundoff From 3c71c132abab164f20adf9c0b140c8967d9855ad Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 17:59:51 -0400 Subject: [PATCH 198/259] +Corrected restart registration for US%m_to_L Corrected the pointer being passed to the restart registration call for m_to_L. This could fix the ability to change the dimensional rescaling between restarts. All answers in the test cases 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 4d18941419..2c62464e87 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2642,7 +2642,7 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Height unit conversion factor", "Z meter-1") call register_restart_field(GV%m_to_H_restart, "m_to_H", .false., restart_CSp, & "Thickness unit conversion factor", "H meter-1") - call register_restart_field(US%m_to_Z_restart, "m_to_L", .false., restart_CSp, & + call register_restart_field(US%m_to_L_restart, "m_to_L", .false., restart_CSp, & "Length unit conversion factor", "L meter-1") call register_restart_field(US%s_to_T_restart, "s_to_T", .false., restart_CSp, & "Time unit conversion factor", "T second-1") From 34e612f676afb1a95b19b12a893c2b918092ff9c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 31 Oct 2019 18:01:35 -0400 Subject: [PATCH 199/259] Pass dt in [T] to tracer_vertdiff for temperature Pass the timestep to the tracer_vertdiff calls for temperature and salinity in units of [T}. This argument is not used in these cases, so this is really just code cleanup. All answers in the test cases are bitwise identical. --- .../vertical/MOM_diabatic_driver.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index ff7da9e870..2db20ae023 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -981,8 +981,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ea_t(i,j,k) = ea_s(i,j,k) ; eb_t(i,j,k) = eb_s(i,j,k) enddo ; enddo ; enddo if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea_t, eb_t, US%T_to_s*dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea_s, eb_s, US%T_to_s*dt, tv%S, G, GV) + call tracer_vertdiff(hold, ea_t, eb_t, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea_s, eb_s, dt, tv%S, G, GV) else call triDiagTS(G, GV, is, ie, js, je, hold, ea_s, eb_s, tv%T, tv%S) endif @@ -1017,8 +1017,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim "and Kd_salt (diabatic)") ! Changes T and S via the tridiagonal solver; no change to h - call tracer_vertdiff(h, ea_t, eb_t, US%T_to_s*dt, tv%T, G, GV) - call tracer_vertdiff(h, ea_s, eb_s, US%T_to_s*dt, tv%S, G, GV) + call tracer_vertdiff(h, ea_t, eb_t, dt, tv%T, G, GV) + call tracer_vertdiff(h, ea_s, eb_s, dt, tv%S, G, GV) ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below if (CS%diabatic_diff_tendency_diag) & @@ -1699,8 +1699,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ! Changes T and S via the tridiagonal solver; no change to h - call tracer_vertdiff(h, ea_t, eb_t, US%T_to_s*dt, tv%T, G, GV) - call tracer_vertdiff(h, ea_s, eb_s, US%T_to_s*dt, tv%S, G, GV) + call tracer_vertdiff(h, ea_t, eb_t, dt, tv%T, G, GV) + call tracer_vertdiff(h, ea_s, eb_s, dt, tv%S, G, GV) ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below @@ -2429,8 +2429,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! between the buffer layers and the interior. ! Changes: T, S if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%S, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) else call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) endif @@ -2521,8 +2521,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Changes T and S via the tridiagonal solver; no change to h if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea, eb, US%T_to_s*dt, tv%S, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) else call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) endif From ce4ed7d12e89a5498e2e3f4a0f3ab689dfae3ad6 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 1 Nov 2019 10:45:25 -0400 Subject: [PATCH 200/259] Kh_max_x[xy], Ah_max_xy chksum and alloc fixes This patch fixes the size of Kh_max_xx, which is on h-points but was incorrectly allocated as if it were on B-points. This also indirectly fixes an issue with the calculation of its checksum. This also fixes two checksum bugs, where the Kh_max_xy and Ah_max_xy were incorrectly computing the Kh_max_xx and Ah_max_xx checksums (respectively). As a side note, this was incorrectly reporting an invariance of the Kh_max_xy checksum, a B-point quanity, since it was computing the Kh_max_xx checksum (h-point) on B-points. This PR resolves the inconsistency of Kh_max_x[xy] and Ah_max_x[xy] checksums across experiments, and slightly reduces Kh_max_xx to its correct size. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index d151a87907..82fddb9dd7 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1834,7 +1834,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 if (CS%bound_Kh .or. CS%better_bound_Kh) then - ALLOC_(CS%Kh_Max_xx(IsdB:IedB,JsdB:JedB)) ; CS%Kh_Max_xx(:,:) = 0.0 + ALLOC_(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed)) ; CS%Kh_Max_xx(:,:) = 0.0 ALLOC_(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_Max_xy(:,:) = 0.0 endif if (CS%Smagorinsky_Kh) then @@ -2096,7 +2096,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) enddo ; enddo if (CS%debug) then call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(CS%Kh_Max_xx, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) endif endif @@ -2158,7 +2158,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) enddo ; enddo if (CS%debug) then call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - call Bchksum(CS%Ah_Max_xx, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) endif endif From ec851edc1052abb498796921b78878dca018b091 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 Nov 2019 10:48:22 -0500 Subject: [PATCH 201/259] Extend z_top and z_btm density calculation in diag The calculate_vertical_integrals function in MOM_diagnostics includes the calculation of density in the z_top and z_btm arrays. The values are initializes from is:ie and js:je, but the int_density_dz function expects these arrays to be defined from isq:ieq+1 and jsq:jeq+1. The reduced init range raises a FPE when signaling NaN initialization is turned on. Previously, these values would have presumably be set to zero. This patch extends the initialization of z_top and z_btm to prevent this issue. --- src/diagnostics/MOM_diagnostics.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7344a5e677..bb1018141c 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -829,15 +829,18 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) call post_data(CS%id_col_ht, z_bot, CS%diag) endif + ! NOTE: int_density_z expects z_top and z_btm values from [ij]sq to [ij]eq+1 if (CS%id_col_mass > 0 .or. CS%id_pbo > 0) then do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo if (GV%Boussinesq) then if (associated(tv%eqn_of_state)) then IG_Earth = 1.0 / GV%mks_g_Earth ! do j=js,je ; do i=is,ie ; z_bot(i,j) = -P_SURF(i,j)/GV%H_to_Pa ; enddo ; enddo - do j=js,je ; do i=is,ie ; z_bot(i,j) = 0.0 ; enddo ; enddo + do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 + z_bot(i,j) = 0.0 + enddo ; enddo do k=1,nz - do j=js,je ; do i=is,ie + do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 z_top(i,j) = z_bot(i,j) z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo From 0eaeb814971d8de5242905ef42439ffa86978f89 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 Nov 2019 11:18:06 -0500 Subject: [PATCH 202/259] Wave speed diag: explicit argument calcs Two function arguments in the wave_speed diagnostic were computed inside of the function call, which operated over the whole array and raised FPEs when initialized with NaNs. 1. The diagonal input igu+igl of the tridiagonal solver tdma6 is replaced with the precomputed Igd(:) = Igu(:) + Igl(:) 2. The Z_to_H rescaling of Hc(:) in remapping_core_h() is replaced with Hc_H, which precomptes the dimensional rescaling. --- src/diagnostics/MOM_wave_speed.F90 | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index f8fc9b7cf9..96295c7674 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -75,12 +75,14 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & pres, T_int, S_int, & gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. real, dimension(SZK_(G)) :: & - Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. + Igl, Igu, Igd ! The inverse of the reduced gravity across an interface times + ! the thickness of the layer below (Igl) or above (Igu) it. + ! Igd is provided for the tridiagonal solver. [s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, Tf, Sf, Rf real, dimension(SZK_(G)) :: & Hc, Tc, Sc, Rc + real, dimension(SZK_(G)) :: Hc_H ! Hc(:) rescaled from Z to thickness real det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 real :: lam, dlam, lam0 real :: min_h_frac @@ -145,8 +147,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & !$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & !$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & -!$OMP drho_dS,drxh_sum,kc,Hc,Tc,Sc,I_Hnew,gprime, & -!$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & +!$OMP drho_dS,drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& +!$OMP Rc,speed2_tot,Igl,Igu,Igd,lam0,lam,lam_it,dlam, & !$OMP mode_struct,sum_hc,N2min,gp,hw, & !$OMP ms_min,ms_max,ms_sq, & !$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) @@ -424,7 +426,10 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif if (calc_modal_structure) then - call tdma6(kc, -igu, igu+igl, -igl, lam, mode_struct) + do k = 1,kc + Igd(k) = Igu(k) + Igl(k) + enddo + call tdma6(kc, -Igu, Igd, -Igl, lam, mode_struct) ms_min = mode_struct(1) ms_max = mode_struct(1) ms_sq = mode_struct(1)**2 @@ -456,8 +461,12 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif ! Note that remapping_core_h requires that the same units be used ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. - call remapping_core_h(CS%remapping_CS, kc, GV%Z_to_H*Hc(:), mode_struct, & - nz, h(i,j,:), modal_structure(i,j,:), 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + do k = 1,kc + Hc_H(k) = GV%Z_to_H * Hc(k) + enddo + call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:), & + 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) endif else cg1(i,j) = 0.0 From aec5eb43562a5e254ce889e270b2925f900a394a Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 Nov 2019 12:02:37 -0500 Subject: [PATCH 203/259] opacity: netPen explicit summation The net penetrating shortwave heat flux at the top level was using colon notation and a SUM() intrinsic, which was causing sums over NaN in Nan-initialized mode, as well as a potentially ambiguous summation ordering. This patch replaces the implicit update and summation with explicit sums over the reduced non-halo domain. --- src/parameterizations/vertical/MOM_opacity.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 5e42de0fea..2c0bfc424e 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -841,7 +841,12 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & pen_SW_bnd(:,:) = iPen_SW_bnd(:,:) do i=is,ie ; h_heat(i) = 0.0 ; enddo - netPen(:,1) = sum( pen_SW_bnd(:,:), dim=1 ) ! Surface interface + do i=is,ie + netPen(i,1) = 0. + do n=1,max(nsw,1) + netPen(i,1) = netPen(i,1) + pen_SW_bnd(n,i) ! Surface interface + enddo + enddo ! Apply penetrating SW radiation to remaining parts of layers. ! Excessively thin layers are not heated to avoid runaway temps. From a016e3b2d393ea09ba12a61587c743af80d28169 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 Nov 2019 13:40:35 -0500 Subject: [PATCH 204/259] Neutral diffusion unit testing tolerance set This patch explicitly sets the Drho_tol and x_tol tolerances to zero for the neutral diffusion unit tests. This was required to avoid FPEs during NaN-initialization, since the unit test does not formally initialize many variables. --- src/tracer/MOM_neutral_diffusion.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 80c6aa242f..c571f679e6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -2401,6 +2401,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Tests for linearized version of searching the layer for neutral surface position ! EOS linear in T, uniform alpha CS%max_iter = 10 + ! Unit tests require explicit initialization of tolerance + CS%Drho_tol = 0. + CS%x_tol = 0. ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., & 0., -0.2, 0., 10., -0.2, 0., & From b2e25115d2165bde26aefc2c58debf42f0d22cd3 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 Nov 2019 13:51:10 -0500 Subject: [PATCH 205/259] advect_x logical test split A conditional test in advect_x of MOM_tracer_advect contained a logical short-circuit: (do_i(i)) .and. (Ihnew(i) > 0.0) where Ihnew was unset if do_i was false. This caused an FPE in builds where short-circuit logic checks were disabled and Ihnew was initialized with NaN. This patch fixes the issue by splitting the statement into two nested if-statements. --- src/tracer/MOM_tracer_advect.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 753faa2a56..4cec179640 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -652,10 +652,14 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & do m=1,ntr ! update tracer - do i=is,ie ; if ((do_i(i)) .and. (Ihnew(i) > 0.0)) then - Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & - (flux_x(I,m) - flux_x(I-1,m))) * Ihnew(i) - endif ; enddo + do i=is,ie + if (do_i(i)) then + if (Ihnew(i) > 0.0) then + Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & + (flux_x(I,m) - flux_x(I-1,m))) * Ihnew(i) + endif + endif + enddo ! diagnostics if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i)) then From 2518c3679c59e047345155c9b8ba3b6cd71d0790 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 Nov 2019 14:45:15 -0500 Subject: [PATCH 206/259] Initialize surface forcing adjustments to zero This patch initializes the global adjusment and scaling factors of the surface forcings to zero. This prevents FPEs when initalizing with NaNs. --- src/core/MOM_forcing_type.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a8c6f7bf1a..a392f90b96 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -150,12 +150,12 @@ module MOM_forcing_type !! or freezing (negative) [m year-1] ! Scalars set by surface forcing modules - real :: vPrecGlobalAdj !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] - real :: saltFluxGlobalAdj !< adjustment to restoring salt flux to zero out global net [kgSalt m-2 s-1] - real :: netFWGlobalAdj !< adjustment to net fresh water to zero out global net [kg m-2 s-1] - real :: vPrecGlobalScl !< scaling of restoring vprec to zero out global net ( -1..1 ) [nondim] - real :: saltFluxGlobalScl !< scaling of restoring salt flux to zero out global net ( -1..1 ) [nondim] - real :: netFWGlobalScl !< scaling of net fresh water to zero out global net ( -1..1 ) [nondim] + real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] + real :: saltFluxGlobalAdj = 0. !< adjustment to restoring salt flux to zero out global net [kgSalt m-2 s-1] + real :: netFWGlobalAdj = 0. !< adjustment to net fresh water to zero out global net [kg m-2 s-1] + real :: vPrecGlobalScl = 0. !< scaling of restoring vprec to zero out global net ( -1..1 ) [nondim] + real :: saltFluxGlobalScl = 0. !< scaling of restoring salt flux to zero out global net ( -1..1 ) [nondim] + real :: netFWGlobalScl = 0. !< scaling of net fresh water to zero out global net ( -1..1 ) [nondim] logical :: fluxes_used = .true. !< If true, all of the heat, salt, and mass !! fluxes have been applied to the ocean. From fa97128879435f67c1573452725c405afc89ee56 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 Nov 2019 15:51:21 -0500 Subject: [PATCH 207/259] MOM_entrain_diffusive logical nesting Two logical checks in MOM_entrain_diffusive were restructured to eliminate short-circuit logical checks which were raise when NaN initialization was enabled. In the first case, a new logical variable (do_entrain_eakb) was introduced to enable nested-and conditions. In the second case, a nested (k == kb) if-block inside of a (k >= kb) block was moved outside as a separate if-block. --- .../vertical/MOM_entrain_diffusive.F90 | 23 +++++++++++++------ 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index a4d8e985cf..6d17fbbe51 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -196,6 +196,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real :: Idt ! The inverse of the time step [T-1 ~> s-1]. logical :: do_any + logical :: do_entrain_eakb ! True if buffer layer is entrained logical :: do_i(SZI_(G)), did_i(SZI_(G)), reiterate, correct_density integer :: it, i, j, k, is, ie, js, je, nz, K2, kmb integer :: kb(SZI_(G)) ! The value of kb in row j. @@ -254,7 +255,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & !$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & !$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & !$OMP zeros,maxF_kb,maxF,ea_kbp1,eakb,Sref, & - !$OMP maxF_correct,do_any, & + !$OMP maxF_correct,do_any,do_entrain_eakb, & !$OMP err_min_eakb0,err_max_eakb0,eakb_maxF, & !$OMP min_eakb,err_eakb0,F,minF,hm,fk,F_kb_maxent,& !$OMP F_kb,is1,ie1,kb_min_act,dFdfm_kb,b1,dFdfm, & @@ -355,10 +356,16 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & kmb, is, ie, G, GV, CS, F_kb_maxEnt, do_i_in = do_i) do i=is,ie - if ((.not.do_i(i)) .or. (err_max_eakb0(i) >= 0.0)) then - eakb(i) = 0.0 ; min_eakb(i) = 0.0 - else ! If error_max_eakb0 < 0 the buffer layers are always all entrained. + do_entrain_eakb = .false. + ! If error_max_eakb0 < 0, then buffer layers are always all entrained + if (do_i(i)) then ; if (err_max_eakb0(i) < 0.0) then + do_entrain_eakb = .true. + endif ; endif + + if (do_entrain_eakb) then eakb(i) = max_eakb(i) ; min_eakb(i) = max_eakb(i) + else + eakb(i) = 0.0 ; min_eakb(i) = 0.0 endif enddo @@ -413,11 +420,13 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif endif do k=nz-1,kb_min,-1 ; do i=is,ie ; if (do_i(i)) then - if (k>=kb(i)) then + if (k >= kb(i)) then maxF(i,k) = MIN(maxF(i,k),dsp1_ds(i,k+1)*maxF(i,k+1) + htot(i)) htot(i) = htot(i) + (h(i,j,k) - Angstrom) - if ( (k == kb(i)) .and. ((maxF(i,k) < F_kb(i)) .or. & - (maxF(i,k) < maxF_kb(i)) .and. (eakb_maxF(i) <= max_eakb(i))) ) then + endif + if (k == kb(i)) then + if ((maxF(i,k) < F_kb(i)) .or. (maxF(i,k) < maxF_kb(i)) & + .and. (eakb_maxF(i) <= max_eakb(i))) then ! In this case, too much was being entrained by the topmost interior ! layer, even with the minimum initial estimate. The buffer layer ! will always entrain the maximum amount. From f607a4523cb923253ff42bcd7e02cfeceba9c8bc Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 5 Nov 2019 11:25:20 -0500 Subject: [PATCH 208/259] MOM_set_viscosity logic split Some of the logical expressions in set_viscous_BBL used to calculcate L(:) (cell width fraction) contained terms which depended on other terms being true and could not be evaluated without short-circuit logic This patch breaks some of the more complex expressions into smaller terms, and pre-computes the logical flags in order avoid logical evaluation FPEs which occur during NaN initialization. --- .../vertical/MOM_set_viscosity.F90 | 33 +++++++++++++------ 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 92466266b8..1e50ddae22 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -260,6 +260,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) real :: C2pi_3 ! An irrational constant, 2/3 pi. real :: tmp ! A temporary variable. real :: tmp_val_m1_to_p1 + real :: curv_tol ! Numerator of curvature cubed, used to estimate + ! accuracy of a single L(:) Newton iteration + logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml integer :: itt, maxitt=20 @@ -773,19 +776,29 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = (vol-Vol_0) ! dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = max(vol-Vol_0, 0.0) - ! The following code is more robust when GV%Angstrom_H=0, but it changes answers. - if (.not.CS%answers_2018) then - Vol_tol = max(0.5*GV%Angstrom_H + GV%H_subroundoff, 1e-14*vol) - Vol_quit = max(0.9*GV%Angstrom_H + GV%H_subroundoff, 1e-14*vol) - endif + use_L0 = .false. + do_one_L_iter = .false. + if (CS%answers_2018) then + curv_tol = GV%Angstrom_H*dV_dL2**2 & + * (0.25 * dV_dL2 * GV%Angstrom_H - a * L0 * dVol) + do_one_L_iter = (a * a * dVol**3) < curv_tol + else + ! The following code is more robust when GV%Angstrom_H=0, but + ! it changes answers. + use_L0 = (dVol <= 0.) + + Vol_tol = max(0.5 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) + Vol_quit = max(0.9 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) + + curv_tol = Vol_tol * dV_dL2**2 & + * (dV_dL2 * Vol_tol - 2.0 * a * L0 * dVol) + do_one_L_iter = (a * a * dVol**3) < curv_tol + endif - if ((.not.CS%answers_2018) .and. (dVol <= 0.0)) then + if (use_L0) then L(K) = L0 Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol - elseif ( ((.not.CS%answers_2018) .and. & - (a*a*dVol**3 < Vol_tol*dV_dL2**2 *(dV_dL2*Vol_tol - 2.0*a*L0*dVol))) .or. & - (CS%answers_2018 .and. (a*a*dVol**3 < GV%Angstrom_H*dV_dL2**2 * & - (0.25*dV_dL2*GV%Angstrom_H - a*L0*dVol) )) ) then + elseif (do_one_L_iter) then ! One iteration of Newton's method should give an estimate ! that is accurate to within Vol_tol. L(K) = sqrt(L0*L0 + dVol / dV_dL2) From 54fc7342ddd8eb8cc9a4e5bbac45e48c9698b60f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 5 Nov 2019 14:38:37 -0500 Subject: [PATCH 209/259] Mixedlayer_restrat density update A zonal density calculation which only updates from is-1:ie+1 was being used in an array update, which include uninitialized halo updates, which raised FPEs for NaN-initialized data. This patch replaces the array update with a loop excluding the unused halo values. --- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 62fb3b6732..f474ed6c83 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -214,7 +214,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt_in_T, MLD_in ! 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) - deltaRhoAtK(:) = deltaRhoAtK(:) - rhoSurf(:) ! Density difference between layer K and surface + do i = is-1,ie+1 + deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface + enddo do i = is-1, ie+1 ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) if ((MLD_fast(i,j)==0.) .and. (ddRho>0.) .and. & From 1a4903e573d963f9e3733083b16a38697781a440 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 9 Nov 2019 11:52:44 -0500 Subject: [PATCH 210/259] Corrected the dimensional rescaling in MOM_MEKE.F90 Corrected the dimensional rescaling in MOM_MEKE.F90; this scaling was not properly automatically merged from dev/gfdl. All answers are bitwise identical in the MOM6-examples test cases. --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 90698ab6a4..55a9a71304 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -778,7 +778,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m EKE = 0. endif if (CS%MEKE_equilibrium_alt) then - MEKE%MEKE(i,j) = (US%Z_to_m*G%bathyT(i,j)*SN / (8*CS%cdrag))**2 + MEKE%MEKE(i,j) = (US%Z_to_L*G%bathyT(i,j) * SN / (8*CS%cdrag))**2 else MEKE%MEKE(i,j) = EKE endif From 1b5d722d3b5ade1138435238c6a284203ee36ad8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 9 Nov 2019 13:21:42 -0500 Subject: [PATCH 211/259] +Added enable_averages Added enable_averages, a new interface for enabling diagnostic averages using a time interval specified in [T]. All answers are bitwise identical, but there is a new public interface. --- src/framework/MOM_diag_mediator.F90 | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 8f762dedd5..c82f3258b6 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -51,7 +51,7 @@ module MOM_diag_mediator public set_masks_for_axes public post_data_1d_k public safe_alloc_ptr, safe_alloc_alloc -public enable_averaging, disable_averaging, query_averaging_enabled +public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid public diag_mediator_infrastructure_init public diag_mediator_close_registration, get_diag_time_end @@ -1807,8 +1807,7 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs) type(time_type), intent(in) :: time_end_in !< The end time of the valid interval type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output -! This subroutine enables the accumulation of time averages over the -! specified time interval. +! This subroutine enables the accumulation of time averages over the specified time interval. ! if (num_file==0) return diag_cs%time_int = time_int_in @@ -1816,6 +1815,26 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs) diag_cs%ave_enabled = .true. end subroutine enable_averaging +!> Enable the accumulation of time averages over the specified time interval in time units. +subroutine enable_averages(time_int, time_end, diag_CS, T_to_s) + real, intent(in) :: time_int !< The time interval over which any values + !! that are offered are valid [T ~> s]. + type(time_type), intent(in) :: time_end !< The end time of the valid interval. + type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to [s]. +! This subroutine enables the accumulation of time averages over the specified time interval. + + if (present(T_to_s)) then + diag_cs%time_int = time_int*T_to_s + elseif (associated(diag_CS%US)) then + diag_cs%time_int = time_int*diag_CS%US%T_to_s + else + diag_cs%time_int = time_int + endif + diag_cs%time_end = time_end + diag_cs%ave_enabled = .true. +end subroutine enable_averages + !> Call this subroutine to avoid averaging any offered fields. subroutine disable_averaging(diag_cs) type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output From 2da48dc19ab9d62baa5229bbdb68480263460f4c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 9 Nov 2019 13:23:25 -0500 Subject: [PATCH 212/259] Use enable_averages in MOM_dynamics modules Enabled averaging diagnostics via calls to enable_averages in MOM_diabatic_driver and the three MOM_dynamics modules. All answers are bitwise identical. --- src/core/MOM_dynamics_split_RK2.F90 | 8 ++++---- src/core/MOM_dynamics_unsplit.F90 | 12 +++++------ src/core/MOM_dynamics_unsplit_RK2.F90 | 8 ++++---- .../vertical/MOM_diabatic_driver.F90 | 20 +++++++++---------- 4 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 43e2684f45..a626efc993 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -12,7 +12,7 @@ module MOM_dynamics_split_RK2 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : diag_mediator_init, enable_averaging +use MOM_diag_mediator, only : diag_mediator_init, enable_averages use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_static_field use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids @@ -405,7 +405,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! PFu = d/dx M(h,T,S) ! pbce = dM/deta - if (CS%begw == 0.0) call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_pres) call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) @@ -474,7 +474,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & enddo ; enddo enddo - call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call enable_averages(dt, Time_local, CS%diag) call set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) @@ -631,7 +631,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & enddo ; enddo ; enddo ! The correction phase of the time step starts here. - call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call enable_averages(dt, Time_local, CS%diag) ! Calculate a revised estimate of the free-surface height correction to be ! used in the next call to btstep. This call is at this point so that diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 5f06b082e1..ed7c440010 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -57,7 +57,7 @@ module MOM_dynamics_unsplit use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : diag_mediator_init, enable_averaging +use MOM_diag_mediator, only : diag_mediator_init, enable_averages use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_static_field use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids @@ -253,7 +253,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & endif ! diffu = horizontal viscosity terms (u,h) - call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, & G, GV, US, CS%hor_visc_CSp) @@ -268,7 +268,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) - call enable_averaging(0.5*US%T_to_s*dt, Time_local-real_to_time(0.5*US%T_to_s*dt), CS%diag) + call enable_averages(0.5*dt, Time_local-real_to_time(0.5*US%T_to_s*dt), CS%diag) ! Here the first half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) @@ -340,7 +340,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! up <- up + dt/2 d/dz visc d/dz up call cpu_clock_begin(id_clock_vertvisc) - call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call enable_averages(dt, Time_local, CS%diag) call set_viscous_ML(u, v, h_av, tv, forces, visc, dt*0.5, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) @@ -428,12 +428,12 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! for vertical remapping may need to be regenerated. call diag_update_remap_grids(CS%diag) - call enable_averaging(0.5*US%T_to_s*dt, Time_local, CS%diag) + call enable_averages(0.5*dt, Time_local, CS%diag) ! Here the second half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) call disable_averaging(CS%diag) - call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call enable_averages(dt, Time_local, CS%diag) ! h_av = (h + hp)/2 do k=1,nz diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 3d4f8777bc..98de5b931c 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -55,7 +55,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : diag_mediator_init, enable_averaging +use MOM_diag_mediator, only : diag_mediator_init, enable_averages use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : register_diag_field, register_static_field use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl @@ -265,7 +265,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, endif ! diffu = horizontal viscosity terms (u,h) - call enable_averaging(US%T_to_s*dt,Time_local, CS%diag) + call enable_averages(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & G, GV, US, CS%hor_visc_CSp) @@ -338,7 +338,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) - call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) + call enable_averages(dt, Time_local, CS%diag) call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_pred, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) @@ -374,7 +374,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) endif -! call enable_averaging(US%T_to_s*dt, Time_local, CS%diag) ?????????????????????/ +! call enable_averages(dt, Time_local, CS%diag) ?????????????????????/ ! up* = u[n] + (1+gamma) * dt * ( PFu + CAu ) Extrapolated for damping ! u*[n+1] = u[n] + dt * ( PFu + CAu ) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 2db20ae023..7f6289337b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -17,7 +17,7 @@ module MOM_diabatic_driver use MOM_diabatic_aux, only : set_pen_shortwave use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids -use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init, diag_grid_storage_end use MOM_diag_mediator, only : diag_copy_diag_to_storage, diag_copy_storage_to_diag use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids @@ -329,7 +329,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*US%T_to_s*dt, Time_end - real_to_time(0.5*US%T_to_s*dt), CS%diag) + call enable_averages(0.5*dt, Time_end - real_to_time(0.5*US%T_to_s*dt), CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) @@ -390,7 +390,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! make_frazil is deliberately called at both the beginning and at ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then - call enable_averaging(0.5*US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(0.5*dt, Time_end, CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) @@ -416,7 +416,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! Diagnose mixed layer depths. - call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(dt, Time_end, CS%diag) if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) @@ -555,7 +555,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! if (showCallTree) call callTree_enter("diabatic_ALE(), MOM_diabatic_driver.F90") ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep - call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(dt, Time_end, CS%diag) if (CS%use_geothermal) then halo = CS%halo_TS_diff @@ -1192,7 +1192,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call disable_averaging(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(dt, Time_end, CS%diag) if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) @@ -1340,7 +1340,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, "The ALE algorithm must be enabled when using MOM_diabatic_driver.") ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep - call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(dt, Time_end, CS%diag) if (CS%use_geothermal) then halo = CS%halo_TS_diff @@ -1875,7 +1875,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call disable_averaging(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(dt, Time_end, CS%diag) if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) @@ -2031,7 +2031,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eaml => eatr ; ebml => ebtr ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep - call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(dt, Time_end, CS%diag) if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then halo = CS%halo_TS_diff @@ -2833,7 +2833,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call disable_averaging(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - call enable_averaging(US%T_to_s*dt, Time_end, CS%diag) + call enable_averages(dt, Time_end, CS%diag) if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) From 148fcf2c101da1718839d29643910bbc9d2c5bb5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 9 Nov 2019 22:55:02 -0500 Subject: [PATCH 213/259] Rescaled timesteps in MOM.F90 Rescaled various internal timesteps in MOM.F90 for code simplification and expanded dimensional consistency testing, including replacing enable_averaging calls with calls to enable_averages, eliminating all use of dt_in_s and renaming dt_in_T back to dt. All answers are bitwise identical. --- src/core/MOM.F90 | 178 ++++++++++++++++++++++++----------------------- 1 file changed, 90 insertions(+), 88 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 5dc412cae7..cb70eefafa 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -11,7 +11,7 @@ module MOM use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : diag_mediator_init, enable_averaging +use MOM_diag_mediator, only : diag_mediator_init, enable_averaging, enable_averages use MOM_diag_mediator, only : diag_mediator_infrastructure_init 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 @@ -164,7 +164,7 @@ module MOM vh, & !< vh = v * h * dx at v grid points [H L2 T-1 ~> m3 s-1 or kg s-1] vhtr !< accumulated meridional thickness fluxes to advect tracers [H L2 ~> m3 or kg] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: ssh_rint - !< A running time integral of the sea surface height [s m]. + !< A running time integral of the sea surface height [T m ~> s m]. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: ave_ssh_ibc !< time-averaged (over a forcing time step) sea surface height !! with a correction for the inverse barometer [m] @@ -175,9 +175,9 @@ module MOM Hml => NULL() !< active mixed layer depth [m] real :: time_in_cycle !< The running time of the current time-stepping cycle !! in calls that step the dynamics, and also the length of - !! the time integral of ssh_rint [s]. + !! the time integral of ssh_rint [T ~> s]. real :: time_in_thermo_cycle !< The running time of the current time-stepping - !! cycle in calls that step the thermodynamics [s]. + !! cycle in calls that step the thermodynamics [T ~> s]. type(ocean_grid_type) :: G !< structure containing metrics and grid info type(verticalGrid_type), pointer :: & @@ -186,14 +186,14 @@ module MOM US => NULL() !< structure containing various unit conversion factors 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 + !! [T ~> s], 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 + !! [T ~> s]. t_dyn_rel_thermo can be negative or positive depending on whether !! the diabatic processes are applied before or after the dynamics and may span !! multiple coupling timesteps. real :: t_dyn_rel_diag !< The time of the diagnostics relative to diabatic processes and remapping - !! (in seconds). t_dyn_rel_diag is always positive, since the diagnostics must lag. + !! [T ~> s]. t_dyn_rel_diag is always positive, since the diagnostics must lag. integer :: ndyn_per_adv = 0 !< Number of calls to dynamics since the last call to advection. !### Must be saved if thermo spans coupling? @@ -214,8 +214,8 @@ module MOM !! This is intended for running MOM6 in offline tracer mode type(time_type), pointer :: Time !< pointer to the ocean clock - real :: dt !< (baroclinic) dynamics time step [s] - real :: dt_therm !< thermodynamics time step [s] + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. integer :: nstep_tot = 0 !< The total number of dynamic timesteps tcaaken @@ -392,7 +392,7 @@ 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_int_in, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & end_cycle, cycle_length, reset_therm) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces @@ -400,7 +400,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & !! tracer and mass exchange 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 [s]. + real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM type(Wave_parameters_CS), & optional, pointer :: Waves !< An optional pointer to a wave property CS @@ -432,17 +432,17 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: dt ! baroclinic time step [s] - real :: dtth ! time step for thickness diffusion [s] - real :: dtdia ! time step for diabatic processes [s] - real :: dt_therm ! a limited and quantized version of CS%dt_therm [s] - real :: dt_therm_here ! a further limited value of dt_therm [s] + real :: time_interval ! time interval covered by this run segment [T ~> s]. + real :: dt ! baroclinic time step [T ~> s] + real :: dtdia ! time step for diabatic processes [T ~> s] + real :: dt_therm ! a limited and quantized version of CS%dt_therm [T ~> s] + real :: dt_therm_here ! a further limited value of dt_therm [T ~> s] real :: wt_end, wt_beg real :: bbl_time_int ! The amount of time over which the calculated BBL ! properties will apply, for use in diagnostics, or 0 - ! if it is not to be calculated anew [s]. - real :: rel_time = 0.0 ! relative time since start of this call [s]. + ! if it is not to be calculated anew [T ~> s]. + real :: rel_time = 0.0 ! relative time since start of this call [T ~> s]. logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. @@ -457,7 +457,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & logical :: cycle_end ! If true, do calculations and diagnostics that are only done at ! the end of a stepping cycle (whatever that may mean). logical :: therm_reset ! If true, reset running sums of thermodynamic quantities. - real :: cycle_time ! The length of the coupled time-stepping cycle [s]. + real :: cycle_time ! The length of the coupled time-stepping cycle [T ~> s]. real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & ssh ! sea surface height, which may be based on eta_av [m] @@ -467,7 +467,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & h => NULL() ! h : layer thickness [H ~> m or kg m-2] real, dimension(:,:), pointer :: & p_surf => NULL() ! A pointer to the ocean surface pressure [Pa]. - real :: I_wt_ssh + real :: I_wt_ssh ! The inverse of the time weights [T-1 ~> s-1] type(time_type) :: Time_local, end_time_thermo, Time_temp type(group_pass_type) :: pass_tau_ustar_psurf @@ -480,13 +480,14 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB u => CS%u ; v => CS%v ; h => CS%h + time_interval = US%s_to_T*time_int_in do_dyn = .true. ; if (present(do_dynamics)) do_dyn = do_dynamics do_thermo = .true. ; if (present(do_thermodynamics)) do_thermo = do_thermodynamics if (.not.(do_dyn .or. do_thermo)) call MOM_error(FATAL,"Step_MOM: "//& "Both do_dynamics and do_thermodynamics are false, which makes no sense.") cycle_start = .true. ; if (present(start_cycle)) cycle_start = start_cycle cycle_end = .true. ; if (present(end_cycle)) cycle_end = end_cycle - cycle_time = time_interval ; if (present(cycle_length)) cycle_time = cycle_length + cycle_time = time_interval ; if (present(cycle_length)) cycle_time = US%s_to_T*cycle_length therm_reset = cycle_start ; if (present(reset_therm)) therm_reset = reset_therm call cpu_clock_begin(id_clock_ocean) @@ -513,10 +514,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ntstep = floor(dt_therm/dt + 0.001) elseif (.not.do_thermo) then dt_therm = CS%dt_therm - if (present(cycle_length)) dt_therm = min(CS%dt_therm, cycle_length) + if (present(cycle_length)) dt_therm = min(CS%dt_therm, US%s_to_T*cycle_length) ! ntstep is not used. else - ntstep = MAX(1,MIN(n_max,floor(CS%dt_therm/dt + 0.001))) + ntstep = MAX(1, MIN(n_max, floor(CS%dt_therm/dt + 0.001))) dt_therm = dt*ntstep endif @@ -562,8 +563,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo if (associated(CS%VarMix)) then - call enable_averaging(cycle_time, Time_start + real_to_time(cycle_time), & - CS%diag) + call enable_averages(cycle_time, Time_start + real_to_time(US%T_to_s*cycle_time), CS%diag) call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix) call disable_averaging(CS%diag) endif @@ -588,7 +588,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (CS%UseWaves) then ! Update wave information, which is presently kept static over each call to step_mom - call enable_averaging(time_interval, Time_start + real_to_time(time_interval), CS%diag) + call enable_averages(time_interval, Time_start + real_to_time(US%T_to_s*time_interval), CS%diag) call Update_Stokes_Drift(G, GV, US, Waves, h, forces%ustar) call disable_averaging(CS%diag) endif @@ -610,9 +610,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do n=1,n_max rel_time = rel_time + dt ! The relative time at the end of the step. ! Set the universally visible time to the middle of the time step. - CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) + CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) ! Set the local time to the end of the time step. - Time_local = Time_start + real_to_time(rel_time) + Time_local = Time_start + real_to_time(US%T_to_s*rel_time) if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) @@ -625,7 +625,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & elseif (thermo_does_span_coupling) then dtdia = dt_therm if ((fluxes%dt_buoy_accum > 0.0) .and. (dtdia > time_interval) .and. & - (abs(fluxes%dt_buoy_accum - dtdia) > 1e-6*dtdia)) then + (abs(US%s_to_T*fluxes%dt_buoy_accum - dtdia) > 1e-6*dtdia)) then call MOM_error(FATAL, "step_MOM: Mismatch between long thermodynamic "//& "timestep and time over which buoyancy fluxes have been accumulated.") endif @@ -639,10 +639,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (dtdia > dt) then ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they begin at the same time. - CS%Time = CS%Time + real_to_time(0.5*(dtdia-dt)) + CS%Time = CS%Time + real_to_time(0.5*US%T_to_s*(dtdia-dt)) ! The end-time of the diagnostic interval needs to be set ahead if there ! are multiple dynamic time steps worth of thermodynamics applied here. - end_time_thermo = Time_local + real_to_time(dtdia-dt) + end_time_thermo = Time_local + real_to_time(US%T_to_s*(dtdia-dt)) endif ! Apply diabatic forcing, do mixing, and regrid. @@ -655,7 +655,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) + CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" if (do_dyn) then @@ -742,7 +742,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they end at the same time. - if (dtdia > dt) CS%Time = CS%Time - real_to_time(0.5*(dtdia-dt)) + if (dtdia > dt) CS%Time = CS%Time - real_to_time(0.5*US%T_to_s*(dtdia-dt)) ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & @@ -757,7 +757,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & endif if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) + CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) endif if (do_dyn) then @@ -780,11 +780,11 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) ! 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 enable_averages(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, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& + CS%CDp, p_surf, US%T_to_s*CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, US, CS%diagnostics_CSp) - call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) + call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, US%T_to_s*CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) @@ -837,12 +837,12 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (cycle_end) then call cpu_clock_begin(id_clock_diagnostics) if (CS%time_in_cycle > 0.0) then - call enable_averaging(CS%time_in_cycle, Time_local, CS%diag) + call enable_averages(CS%time_in_cycle, Time_local, CS%diag) call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state, ssh) endif if (CS%time_in_thermo_cycle > 0.0) then - call enable_averaging(CS%time_in_thermo_cycle, Time_local, CS%diag) - call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & + call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) + call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, US%T_to_s*CS%time_in_thermo_cycle, & sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) @@ -857,7 +857,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (MOM_state_is_synchronized(CS)) & call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & G, GV, US, CS%sum_output_CSp, CS%tracer_flow_CSp, & - dt_forcing=real_to_time(time_interval) ) + dt_forcing=real_to_time(US%T_to_s*time_interval) ) call cpu_clock_end(id_clock_other) @@ -867,7 +867,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & end subroutine step_MOM !> Time step the ocean dynamics, including the momentum and continuity equations -subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_thermo, & +subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & bbl_time_int, CS, Time_local, Waves) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface @@ -876,11 +876,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface !! pressure at the end of this dynamic step, !! intent in [Pa]. - real, intent(in) :: dt_in_s !< time interval covered by this call [s]. + real, intent(in) :: dt !< time interval covered by this call [T ~> s]. real, intent(in) :: dt_thermo !< time interval covered by any updates that may - !! span multiple dynamics steps [s]. + !! span multiple dynamics steps [T ~> s]. real, intent(in) :: bbl_time_int !< time interval over which updates to the - !! bottom boundary layer properties will apply [s], + !! bottom boundary layer properties will apply [T ~> s], !! or zero not to update the properties. type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM type(time_type), intent(in) :: Time_local !< End time of a segment, as a time type @@ -900,7 +900,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1] h => NULL() ! h : layer thickness [H ~> m or kg m-2] - real :: dt_in_T ! The time step covered by this call [T ~> s] logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. logical :: showCallTree @@ -917,15 +916,14 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm showCallTree = callTree_showQuery() call cpu_clock_begin(id_clock_dynamics) - dt_in_T = US%s_to_T*dt_in_s if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then - call enable_averaging(dt_thermo, Time_local+real_to_time(dt_thermo-dt_in_s), CS%diag) + call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(dt_thermo-dt)), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt_in_T, G, GV, US, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, US%s_to_T*dt_thermo, G, GV, US, & + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & 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)) @@ -939,8 +937,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm ! The bottom boundary layer properties need to be recalculated. if (bbl_time_int > 0.0) then - call enable_averaging(bbl_time_int, & - Time_local + real_to_time(bbl_time_int-dt_in_s), CS%diag) + call enable_averages(bbl_time_int, & + Time_local + real_to_time(US%T_to_s*(bbl_time_int-dt)), CS%diag) ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) call set_viscous_BBL(CS%u(:,:,:), CS%v(:,:,:), CS%h, CS%tv, CS%visc, G, GV, US, & @@ -964,7 +962,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm endif endif - call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt_in_T, forces, & + call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & CS%MEKE, CS%thickness_diffuse_CSp, waves=waves) @@ -979,11 +977,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm ! 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_in_T, forces, & + call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, 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_in_T, forces, & + call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, Waves=Waves) endif @@ -997,8 +995,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm 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_in_T, G, GV, US, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_in_T, G, GV, US, & + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & 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) @@ -1015,7 +1013,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) - call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt_in_T, CS%visc%MLD, & + call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & CS%VarMix, G, GV, US, 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)) @@ -1031,19 +1029,19 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt_in_s, dt_therm 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_in_T, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) + CS%visc, dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) call disable_averaging(CS%diag) ! Advance the dynamics time by dt. - CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt_in_s - CS%t_dyn_rel_thermo = CS%t_dyn_rel_thermo + dt_in_s - if (abs(CS%t_dyn_rel_thermo) < 1e-6*dt_in_s) CS%t_dyn_rel_thermo = 0.0 - CS%t_dyn_rel_diag = CS%t_dyn_rel_diag + dt_in_s + CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt + CS%t_dyn_rel_thermo = CS%t_dyn_rel_thermo + dt + if (abs(CS%t_dyn_rel_thermo) < 1e-6*dt) CS%t_dyn_rel_thermo = 0.0 + CS%t_dyn_rel_diag = CS%t_dyn_rel_diag + dt call cpu_clock_end(id_clock_dynamics) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) - call enable_averaging(dt_in_s, Time_local, CS%diag) + call enable_averages(dt, Time_local, CS%diag) ! These diagnostics are available after every time dynamics step. 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) @@ -1085,20 +1083,20 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) 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_averages(CS%t_dyn_rel_adv, Time_local, CS%diag) - call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, US%s_to_T*CS%t_dyn_rel_adv, G, GV, US, & + call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & CS%tracer_adv_CSp, CS%tracer_Reg) - call tracer_hordiff(h, US%s_to_T*CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & - CS%t_dyn_rel_adv, CS%tracer_Reg) + US%T_to_s*CS%t_dyn_rel_adv, CS%tracer_Reg) 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, US, CS%uhtr, CS%vhtr, h, CS%transport_IDs, & - CS%diag_pre_dyn, CS%diag, CS%t_dyn_rel_adv, CS%tracer_reg) + CS%diag_pre_dyn, CS%diag, US%T_to_s*CS%t_dyn_rel_adv, CS%tracer_reg) ! 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) @@ -1140,7 +1138,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & intent(inout) :: h !< layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - real, intent(in) :: dtdia !< The time interval over which to advance [s] + real, intent(in) :: dtdia !< The time interval over which to advance [T ~> s] type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. type(wave_parameters_CS), & @@ -1161,10 +1159,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & use_ice_shelf = .false. if (associated(fluxes%frac_shelf_h)) use_ice_shelf = .true. - call enable_averaging(dtdia, Time_end_thermo, CS%diag) + call enable_averages(dtdia, Time_end_thermo, CS%diag) if (associated(CS%odaCS)) then - call apply_oda_tracer_increments(dtdia,G,tv,h,CS%odaCS) + call apply_oda_tracer_increments(US%T_to_s*dtdia,G,tv,h,CS%odaCS) endif if (update_BBL) then @@ -1194,7 +1192,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_diabatic) call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & - US%s_to_T*dtdia, Time_end_thermo, G, GV, US, CS%diabatic_CSp, Waves=Waves) + dtdia, Time_end_thermo, G, GV, US, CS%diabatic_CSp, Waves=Waves) fluxes%fluxes_used = .true. if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -1203,7 +1201,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! (that may comprise several dynamical time steps) ! The routine 'ALE_main' can be found in 'MOM_ALE.F90'. if ( CS%use_ALE_algorithm ) then - call enable_averaging(dtdia, Time_end_thermo, CS%diag) + call enable_averages(dtdia, Time_end_thermo, CS%diag) ! call pass_vector(u, v, G%Domain) if (associated(tv%T)) & call create_group_pass(pass_T_S_h, tv%T, G%Domain, To_All+Omit_Corners, halo=1) @@ -1223,9 +1221,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_ALE) if (use_ice_shelf) then call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, & - dtdia, fluxes%frac_shelf_h) + US%T_to_s*dtdia, fluxes%frac_shelf_h) else - call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, dtdia) + call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, US%T_to_s*dtdia) endif if (showCallTree) call callTree_waypoint("finished ALE_main (step_MOM_thermo)") @@ -1254,7 +1252,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call diag_update_remap_grids(CS%diag) !### Consider moving this up into the if ALE block. - call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) + call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, US%T_to_s*dtdia) if (CS%debug) then call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) @@ -1278,7 +1276,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & else ! complement of "if (.not.CS%adiabatic)" call cpu_clock_begin(id_clock_diabatic) - call adiabatic(h, tv, fluxes, dtdia, G, GV, CS%diabatic_CSp) + call adiabatic(h, tv, fluxes, US%T_to_s*dtdia, G, GV, CS%diabatic_CSp) fluxes%fluxes_used = .true. call cpu_clock_end(id_clock_diabatic) @@ -1327,6 +1325,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: do_vertical !< If enough time has elapsed, do the diabatic tracer sources/sinks logical :: adv_converged !< True if all the horizontal fluxes have been used + real :: dt_off ! The offline timestep [T ~> s] integer :: dt_offline, dt_offline_vertical logical :: skip_diffusion integer :: id_eta_diff_end @@ -1355,6 +1354,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & dt_offline, dt_offline_vertical, skip_diffusion) Time_end = increment_date(Time_start, seconds=floor(time_interval+0.001)) + dt_off = US%s_to_T*REAL(dt_offline) + call enable_averaging(time_interval, Time_end, CS%diag) ! Check to see if this is the first iteration of the offline interval @@ -1405,9 +1406,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, US%s_to_T*REAL(dt_offline), G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_off, G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, US%s_to_T*REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1430,9 +1431,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, US%s_to_T*REAL(dt_offline), G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_off, G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, US%s_to_T*REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1467,8 +1468,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS CS%h, eatr, ebtr, uhtr, vhtr) ! Perform offline diffusion if requested if (.not. skip_diffusion) then - call tracer_hordiff(h_end, US%s_to_T*REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, US, & - CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + call tracer_hordiff(h_end, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & + CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif CS%h = h_end @@ -1739,7 +1740,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "The (baroclinic) dynamics time step. The time-step that "//& "is actually used will be an integer fraction of the "//& "forcing time-step (DT_FORCING in ocean-only mode or the "//& - "coupling timestep in coupled mode.)", units="s", & + "coupling timestep in coupled mode.)", units="s", scale=US%s_to_T, & fail_if_missing=.true.) call get_param(param_file, "MOM", "DT_THERM", CS%dt_therm, & "The thermodynamic and tracer advection time step. "//& @@ -1747,7 +1748,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=CS%dt) + "default DT_THERM is set to DT.", & + units="s", scale=US%s_to_T, default=US%T_to_s*CS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", CS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -1781,7 +1783,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%split) then call get_param(param_file, "MOM", "DTBT", dtbt, default=-0.98) - default_val = CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 + default_val = US%T_to_s*CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 CS%dtbt_reset_period = -1.0 call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & "The period between recalculations of DTBT (if DTBT <= 0). "//& @@ -2309,7 +2311,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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, & G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & - US%s_to_T*CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & + CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt) From 81f3a58e3e61c9dca32a80ec53781775ed11117d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 12 Nov 2019 12:52:30 -0500 Subject: [PATCH 214/259] RK2 split pass_init clock timer initialization The initial pass_var timer was being initialized after it was used in the split RK2 timestep solver, which was causing it to be ignored in 0-initialized integers, and raising errors during integer initialization tests. This patch moves the initialization to earlier in the function, which resolves this error. --- src/core/MOM_dynamics_split_RK2.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 1f43a699a1..97441d56e0 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1105,6 +1105,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt ! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av + id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', & + grain=CLOCK_ROUTINE) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv_CSp) if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) @@ -1244,7 +1247,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param id_clock_horvisc = cpu_clock_id('(Ocean horizontal viscosity)', grain=CLOCK_MODULE) id_clock_mom_update = cpu_clock_id('(Ocean momentum increments)', grain=CLOCK_MODULE) id_clock_pass = cpu_clock_id('(Ocean message passing)', grain=CLOCK_MODULE) - id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE) id_clock_btcalc = cpu_clock_id('(Ocean barotropic mode calc)', grain=CLOCK_MODULE) id_clock_btstep = cpu_clock_id('(Ocean barotropic mode stepping)', grain=CLOCK_MODULE) id_clock_btforce = cpu_clock_id('(Ocean barotropic forcing calc)', grain=CLOCK_MODULE) From a919f238b5f3104e07b447e4c16d418b82964561 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 12 Nov 2019 15:46:05 -0500 Subject: [PATCH 215/259] +Fixed unit conversion factors for 7 diagnostics Fixed dimensional rescaling unit conversion factors for 7 diagnostics and pass the timestep to neutral_diffusion in [T] for diagnostic purposes. All answers are bitwise identical. --- .../vertical/MOM_diabatic_driver.F90 | 4 ++-- src/tracer/MOM_neutral_diffusion.F90 | 12 ++++++------ src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 12 ++++++------ 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7f6289337b..f7dcc5fd4f 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3525,7 +3525,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_saln_tend = register_diag_field('ocean_model',& 'diabatic_diff_saln_tendency', diag%axesTL, Time, & - 'Diabatic diffusion salinity tendency', 'psu s-1') + 'Diabatic diffusion salinity tendency', 'psu s-1', conversion=US%s_to_T) if (CS%id_diabatic_diff_saln_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif @@ -3637,7 +3637,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! This diagnostic should equal to surface salt flux if all is working well. CS%id_boundary_forcing_salt_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency_2d', diag%axesT1, Time, & - 'Depth integrated boundary forcing of ocean salt','kg m-2 s-1') + 'Depth integrated boundary forcing of ocean salt','kg m-2 s-1', conversion=US%s_to_T) if (CS%id_boundary_forcing_salt_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 80c6aa242f..8c130b49bd 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -435,7 +435,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts + real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] !! (I_numitts in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -454,7 +454,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: i, j, k, m, ks, nk - real :: Idt + real :: Idt ! The inverse of the time step [T-1 ~> s-1] real :: h_neglect, h_neglect_edge !### Try replacing both of these with GV%H_subroundoff @@ -468,10 +468,10 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) tracer => Reg%Tr(m) ! for diagnostics - 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 + 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 endif uFlx(:,:,:) = 0. diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 5e0e0ae600..3dd89881b2 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -407,7 +407,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call neutral_diffusion_calc_coeffs(G, GV, h, tv%T, tv%S, CS%neutral_diffusion_CSp) endif endif - call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*US%T_to_s*dt, Reg, US, CS%neutral_diffusion_CSp) + call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, US, CS%neutral_diffusion_CSp) enddo ! itt else ! following if not using neutral diffusion, but instead along-surface diffusion diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index ce9ea4285b..5f32fb104e 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -478,19 +478,19 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated lateral or neutral diffusion tracer concentration "//& - "tendency for "//trim(shortnm), conv_units, conversion = Tr%conv_scale, & - x_cell_method = 'sum', y_cell_method = 'sum') + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & + x_cell_method='sum', y_cell_method= 'sum') else cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//& ' expressed as '//trim(lowercase(flux_longname))//& ' content due to parameterized mesoscale diffusion' 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_tendprefix)//'pmdiff', & + conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name = trim(Tr%cmor_tendprefix)//'pmdiff', & cmor_long_name = trim(cmor_var_lname), cmor_standard_name = trim(cmor_long_std(cmor_var_lname)), & x_cell_method = 'sum', y_cell_method = 'sum', v_extensive = .true.) @@ -499,13 +499,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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_tendprefix)//'pmdiff_2d', & + conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & x_cell_method='sum', y_cell_method='sum') endif Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & diag%axesTL, Time, "Lateral (neutral) tracer concentration tendency for "//trim(shortnm), & - trim(units)//' s-1') + trim(units)//' s-1', conversion=US%s_to_T) var_lname = "Net time tendency for "//lowercase(flux_longname) if (len_trim(Tr%cmor_tendprefix) == 0) then From 186bedacbf07bf521b73a270cd0fe4630f7d25b3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 12 Nov 2019 19:00:45 -0500 Subject: [PATCH 216/259] +Pass timesteps to diagnostic routines in [T] Rescaled the timesteps passed to calculate_diagnostic_fields, post_surface_thermo_diags and post_transport_diagnostics in units of [T] for more complete dimensional consistency testing. Also added unit_scale_type argument to register_surface_diags. All answers and diagnostics are bitwise identical. --- src/core/MOM.F90 | 8 +++--- src/diagnostics/MOM_diagnostics.F90 | 41 ++++++++++++++++------------- 2 files changed, 26 insertions(+), 23 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index cb70eefafa..a29a555f55 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -782,7 +782,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & call enable_averages(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, p_surf, US%T_to_s*CS%t_dyn_rel_diag, CS%diag_pre_sync,& + CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, US, CS%diagnostics_CSp) call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, US%T_to_s*CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) @@ -842,7 +842,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & endif if (CS%time_in_thermo_cycle > 0.0) then call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) - call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, US%T_to_s*CS%time_in_thermo_cycle, & + call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) @@ -1096,7 +1096,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) call post_transport_diagnostics(G, GV, US, CS%uhtr, CS%vhtr, h, CS%transport_IDs, & - CS%diag_pre_dyn, CS%diag, US%T_to_s*CS%t_dyn_rel_adv, CS%tracer_reg) + CS%diag_pre_dyn, CS%diag, CS%t_dyn_rel_adv, CS%tracer_reg) ! 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) @@ -2380,7 +2380,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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%tv) + call register_surface_diags(Time, G, US, CS%sfc_IDs, CS%diag, CS%tv) call register_diags(Time, G, GV, US, CS%IDs, CS%diag) call register_transport_diags(Time, G, GV, US, CS%transport_IDs, CS%diag) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, US, & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 28ecb539d7..d4fa0a59c8 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -66,9 +66,9 @@ module MOM_diagnostics ! following fields have nz layers. real, pointer, dimension(:,:,:) :: & - du_dt => NULL(), & !< net i-acceleration [L T-1 s-1 ~> m s-2] - dv_dt => NULL(), & !< net j-acceleration [L T-1 s-1 ~> m s-2] - dh_dt => NULL(), & !< thickness rate of change [H s-1 ~> m s-1 or kg m-2 s-1] + du_dt => NULL(), & !< net i-acceleration [L T-2 ~> m s-2] + dv_dt => NULL(), & !< net j-acceleration [L T-2 ~> m s-2] + dh_dt => NULL(), & !< thickness rate of change [H T-1 ~> m s-1 or kg m-2 s-1] p_ebt => NULL() !< Equivalent barotropic modal structure [nondim] real, pointer, dimension(:,:,:) :: h_Rlay => NULL() !< Layer thicknesses in potential density @@ -210,7 +210,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! If p_surf is not associated, it is the same !! as setting the surface pressure to 0. real, intent(in) :: dt !< The time difference since the last - !! call to this subroutine [s]. + !! call to this subroutine [T ~> s]. type(diag_grid_storage), intent(in) :: diag_pre_sync !< Target grids from previous timestep type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a !! previous call to diagnostics_init. @@ -255,7 +255,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (loc(CS)==0) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") - call calculate_derivs(US%s_to_T*dt, G, CS) + call calculate_derivs(dt, G, CS) if (dt > 0.0) then call diag_save_grids(CS%diag) @@ -642,19 +642,19 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_cfl_cg1>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1(i,j) = (dt*US%m_to_L*CS%cg1(i,j)) * (G%IdxT(i,j) + G%IdyT(i,j)) + CS%cfl_cg1(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * (G%IdxT(i,j) + G%IdyT(i,j)) enddo ; enddo call post_data(CS%id_cfl_cg1, CS%cfl_cg1, CS%diag) endif if (CS%id_cfl_cg1_x>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1_x(i,j) = (dt*US%m_to_L*CS%cg1(i,j)) * G%IdxT(i,j) + CS%cfl_cg1_x(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * G%IdxT(i,j) enddo ; enddo call post_data(CS%id_cfl_cg1_x, CS%cfl_cg1_x, CS%diag) endif if (CS%id_cfl_cg1_y>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1_y(i,j) = (dt*US%m_to_L*CS%cg1(i,j)) * G%IdyT(i,j) + CS%cfl_cg1_y(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * G%IdyT(i,j) enddo ; enddo call post_data(CS%id_cfl_cg1_y, CS%cfl_cg1_y, CS%diag) endif @@ -1203,7 +1203,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - real, intent(in) :: dt_int !< total time step associated with these diagnostics [s]. + real, intent(in) :: dt_int !< total time step associated with these diagnostics [T ~> 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)), & @@ -1214,7 +1214,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv 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 [m] - real :: I_time_int ! The inverse of the time interval [s-1]. + real :: I_time_int ! The inverse of the time interval [T-1 ~> s-1]. real :: zos_area_mean, volo, ssh_ga integer :: i, j, is, ie, js, je @@ -1353,7 +1353,7 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy type(transport_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(diag_grid_storage), intent(inout) :: diag_pre_dyn !< Stored grids from before dynamics type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real, intent(in) :: dt_trans !< total time step associated with the transports [s]. + real, intent(in) :: dt_trans !< total time step associated with the transports [T ~> s]. type(tracer_registry_type), pointer :: Reg !< Pointer to the tracer registry ! Local variables @@ -1363,14 +1363,14 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy real, dimension(SZI_(G), SZJB_(G), SZK_(G)) :: vmo ! Diagnostics of layer mass transport [kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tend ! Change in layer thickness due to dynamics ! [H s-1 ~> m s-1 or kg m-2 s-1]. - real :: Idt ! The inverse of the time interval [s-1] + real :: Idt ! The inverse of the time interval [T-1 ~> s-1] real :: H_to_kg_m2_dt ! A conversion factor from accumulated transports to fluxes ! [kg L-2 H-1 s-1 ~> kg m-3 s-1 or s-1]. 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 = 1. / dt_trans - H_to_kg_m2_dt = GV%H_to_kg_m2 * US%L_to_m**2 * Idt + H_to_kg_m2_dt = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T * Idt call diag_save_grids(diag) call diag_copy_storage_to_diag(diag, diag_pre_dyn) @@ -1734,9 +1734,10 @@ end subroutine MOM_diagnostics_init !> Register diagnostics of the surface state and integrated quantities -subroutine register_surface_diags(Time, G, IDs, diag, tv) +subroutine register_surface_diags(Time, G, US, IDs, diag, tv) type(time_type), intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables @@ -1790,18 +1791,20 @@ subroutine register_surface_diags(Time, G, IDs, diag, tv) 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', & + 'Heat from frazil formation', 'W m-2', conversion=US%s_to_T, 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', conversion=G%US%R_to_kg_m3*G%US%Z_to_m) + 'Salt sink in ocean due to ice flux', & + 'psu m-2 s-1', conversion=G%US%R_to_kg_m3*G%US%Z_to_m*US%s_to_T) 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', conversion=G%US%R_to_kg_m3*G%US%Z_to_m) + 'Heat flux into ocean from mass flux into ocean', & + 'W m-2', conversion=G%US%R_to_kg_m3*G%US%Z_to_m*US%s_to_T) 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') + 'Heat flux into ocean from geothermal or other internal sources', 'W m-2', conversion=US%s_to_T) end subroutine register_surface_diags @@ -1848,7 +1851,7 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) 'm s-1', v_extensive=.true., conversion=GV%H_to_m) IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & - 'm s-1', v_extensive=.true., conversion=GV%H_to_m) + 'm s-1', v_extensive=.true., conversion=GV%H_to_m*US%s_to_T) end subroutine register_transport_diags From ef462a8229f21541974d28a51854381951812ef1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 13 Nov 2019 10:49:11 -0500 Subject: [PATCH 217/259] Removed the accidental 2 in a comment --- config_src/mct_driver/mom_surface_forcing_mct.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 148c855c63..b487787a2e 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -237,7 +237,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & !! is present, or false (no restoring) otherwise. logical :: restore_sst !< local copy of the argument restore_temp, if it !! is present, or false (no restoring) otherwise. - real :: delta_sss !< temporary storage for sss diff from restoring value2 + real :: delta_sss !< temporary storage for sss diff from restoring value real :: delta_sst !< temporary storage for sst diff from restoring value real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling From 18e589420875d7909916c29cb14f0c4dc121966c Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 13 Nov 2019 12:00:40 -0500 Subject: [PATCH 218/259] Enable tc4.restart test --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 16958cebea..924f983dfb 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -182,7 +182,7 @@ test: $(foreach t,$(TESTS),test.$(t)) test.regressions: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) test.grids: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(c).grid $(c).grid.diag) test.layouts: $(foreach c,$(CONFIGS),$(c).layout $(c).layout.diag) -test.restarts: $(foreach c,$(filter-out tc4,$(CONFIGS)),$(c).restart) +test.restarts: $(foreach c,$(CONFIGS),$(c).restart) test.repros: $(foreach c,$(CONFIGS),$(c).repro $(c).repro.diag) test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) From 605d1bc6f7db12b5e2ce3553f36f1c749fdb7eaf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 13 Nov 2019 15:15:52 -0500 Subject: [PATCH 219/259] +Pass timeesteps to tracer diagnostics in [T] Pass timeesteps to the tracer diagnistics routines post_tracer_diagnostics and postALE_tracer_diagnostics and to adiabatic in units of [T}. All answers are bitwise identical. --- src/core/MOM.F90 | 6 ++--- .../vertical/MOM_diabatic_driver.F90 | 9 ++++---- src/tracer/MOM_tracer_registry.F90 | 22 +++++++++---------- 3 files changed, 19 insertions(+), 18 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a29a555f55..62fe0fe5f9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -784,7 +784,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, US, CS%diagnostics_CSp) - call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, US%T_to_s*CS%t_dyn_rel_diag) + call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) @@ -1252,7 +1252,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call diag_update_remap_grids(CS%diag) !### Consider moving this up into the if ALE block. - call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, US%T_to_s*dtdia) + 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, scale=US%L_T_to_m_s) @@ -1276,7 +1276,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & else ! complement of "if (.not.CS%adiabatic)" call cpu_clock_begin(id_clock_diabatic) - call adiabatic(h, tv, fluxes, US%T_to_s*dtdia, G, GV, CS%diabatic_CSp) + call adiabatic(h, tv, fluxes, dtdia, G, GV, US, CS%diabatic_CSp) fluxes%fluxes_used = .true. call cpu_clock_end(id_clock_diabatic) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index f7dcc5fd4f..dca57e0a03 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -258,7 +258,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] @@ -274,6 +273,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations real, intent(in) :: dt !< time increment [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves @@ -2885,21 +2885,22 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & end subroutine extract_diabatic_member !> Routine called for adiabatic physics -subroutine adiabatic(h, tv, fluxes, dt, G, GV, CS) +subroutine adiabatic(h, tv, fluxes, dt, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields type(forcing), intent(inout) :: fluxes !< boundary fluxes - real, intent(in) :: dt !< time step [s] + real, intent(in) :: dt !< time step [T ~> s] type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: zeros ! An array of zeros. zeros(:,:,:) = 0.0 - call call_tracer_column_fns(h, h, zeros, zeros, fluxes, zeros(:,:,1), dt, G, GV, tv, & + call call_tracer_column_fns(h, h, zeros, zeros, fluxes, zeros(:,:,1), US%T_to_s*dt, G, GV, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) end subroutine adiabatic diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 5f32fb104e..bd7871fe5e 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -465,7 +465,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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') + 'Net time tendency for '//trim(lowercase(longname)), trim(units)//' s-1', conversion=US%s_to_T) if (Tr%id_tendency > 0) then call safe_alloc_ptr(Tr%t_prev,isd,ied,jsd,jed,nz) @@ -511,10 +511,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) if (len_trim(Tr%cmor_tendprefix) == 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., & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale*US%s_to_T) 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, & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale*US%s_to_T) else cmor_var_lname = "Tendency of "//trim(cmor_longname)//" Expressed as "//& trim(flux_longname)//" Content" @@ -522,13 +522,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) diag%axesTL, Time, var_lname, conv_units, & cmor_field_name=trim(Tr%cmor_tendprefix)//"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*US%s_to_T) 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_tendprefix)//"tend_2d", & cmor_standard_name=cmor_long_std(cmor_var_lname), cmor_long_name=cmor_var_lname, & - conversion=Tr%conv_scale) + conversion=Tr%conv_scale*US%s_to_T) 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) @@ -561,7 +561,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) unit2 = trim(units)//"2" if (index(units(1:len_trim(units))," ") > 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") + Time, "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1", conversion=US%s_to_T) if (Tr%id_tr_vardec > 0) then ! Set up a new tracer for this tracer squared m2 = Reg%ntr+1 @@ -604,10 +604,10 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) 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, intent(in) :: dt !< total time interval for these diagnostics [T ~> s] - real :: work(SZI_(G),SZJ_(G),SZK_(G)) - real :: Idt + real :: work(SZI_(G),SZJ_(G),SZK_(G)) + real :: Idt ! The inverse of the time step [T-1 ~> s-1] 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 @@ -636,11 +636,11 @@ subroutine post_tracer_diagnostics(Reg, h, diag_prev, diag, G, GV, dt) intent(in) :: h !< Layer thicknesses type(diag_grid_storage), intent(in) :: diag_prev !< Contains diagnostic grids from previous timestep type(diag_ctrl), intent(inout) :: diag !< structure to regulate diagnostic output - real, intent(in) :: dt !< total time step for tracer updates + real, intent(in) :: dt !< total time step for tracer updates [T ~> s] real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) real :: work2d(SZI_(G),SZJ_(G)) - real :: Idt + real :: Idt ! The inverse of the time step [T-1 ~> s-1] 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 From 08dbb595ff74f4cb4ad3d6137a3b516650131faa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 13 Nov 2019 17:04:47 -0500 Subject: [PATCH 220/259] +Rescaled tracer advective flux diagnostics Rescaled the internal units of the tracer advective flux diagnostics to units of [conc H L2 T-1] for code simplicity and dimensional consistency testing. Also corrected the units of some tracer fluxes as documented in comments and commented out unused elements of the tracer_type. All answers are bitwise identical. --- src/tracer/MOM_tracer_advect.F90 | 8 ++-- src/tracer/MOM_tracer_registry.F90 | 70 ++++++++++++++++-------------- 2 files changed, 41 insertions(+), 37 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 164ba483b6..77d28e6767 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -661,10 +661,10 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! diagnostics if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + US%L_to_m**2*flux_x(I,m)*Idt + Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,m)*Idt endif ; enddo ; endif if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + US%L_to_m**2*flux_x(I,m)*Idt + Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,m)*Idt endif ; enddo ; endif ! diagnose convergence of flux_x (do not use the Ihnew(i) part of the logic). @@ -1030,10 +1030,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! diagnostics if (associated(Tr(m)%ad_y)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + US%L_to_m**2*flux_y(i,m,J)*Idt + Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt endif ; enddo ; endif if (associated(Tr(m)%ad2d_y)) then ; do i=is,ie ; if (do_i(i)) then - Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + US%L_to_m**2*flux_y(i,m,J)*Idt + Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt endif ; enddo ; endif ! diagnose convergence of flux_y and add to convergence of flux_x. diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index bd7871fe5e..663bfe1037 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -45,33 +45,33 @@ module MOM_tracer_registry ! !! specified in OBCs through v-face of cell real, dimension(:,:,:), pointer :: ad_x => NULL() !< diagnostic array for x-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: ad_y => NULL() !< diagnostic array for y-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_x => NULL() !< diagnostic vertical sum x-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_y => NULL() !< diagnostic vertical sum y-advective tracer flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux - !! [conc H L2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux - !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux +! !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux +! !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes - !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] - real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes - !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] - real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes - !! expressed as a change in concentration [conc s-1] + !! [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! expressed as a change in concentration [conc s-1] real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous !! timestep used for diagnostics [conc] real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array @@ -102,8 +102,8 @@ module MOM_tracer_registry integer :: ind_tr_squared = -1 !< The tracer registry index for the square of this tracer !### 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 :: 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. @@ -162,18 +162,22 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit !! tracer cells (units of tracer CONC) ! The following are probably not necessary if registry_diags is present and true. - 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_x !< diagnostic x-advective flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux - !! (CONC m3/s or CONC*kg/s) + !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] 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 @@ -393,11 +397,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & - conversion=Tr%flux_scale*US%s_to_T) + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & - conversion=Tr%flux_scale*US%s_to_T) + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & @@ -409,10 +413,10 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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*US%s_to_T, y_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, 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*US%s_to_T, x_cell_method = 'sum') + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, 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=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & @@ -430,11 +434,11 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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*US%s_to_T, y_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, 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*US%s_to_T, x_cell_method = 'sum') + flux_units, conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, 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), & From 00da24e78d4fcd8bb336a5c39b10aaad2006cee5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 13 Nov 2019 18:09:09 -0500 Subject: [PATCH 221/259] +Pass timesteps to ALE_main in [T] Pass the timesteps to ALE_main, ALE_main_offline, and ALE_main_accelerated in units of [T] for code simplicity and dimensional consistency testing. This also includes the rescaling of remapping-driven tracer tendencies. All answers and diagnostics are bitwise identical. --- src/ALE/MOM_ALE.F90 | 23 ++++++++++--------- src/core/MOM.F90 | 6 ++--- .../MOM_state_initialization.F90 | 4 ++-- src/tracer/MOM_offline_main.F90 | 2 +- src/tracer/MOM_tracer_registry.F90 | 6 ++--- 5 files changed, 21 insertions(+), 20 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 7a090bb400..d7917f8cad 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -68,7 +68,7 @@ module MOM_ALE !! remaps between grids described by h. real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid - !! and the target (new) grid. (s) + !! and the target (new) grid [T ~> s] type(regridding_CS) :: regridCS !< Regridding parameters and work arrays type(remapping_CS) :: remapCS !< Remapping parameters and work arrays @@ -209,7 +209,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "and the target (new) grid. A short time-scale favors the target "//& "grid (0. or anything less than DT_THERM) has no memory of the old "//& "grid. A very long time-scale makes the model more Lagrangian.", & - units="s", default=0.) + units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "REGRID_FILTER_SHALLOW_DEPTH", filter_shallow_depth, & "The depth above which no time-filtering is applied. Above this depth "//& "final grid exactly matches the target (new) grid.", & @@ -269,7 +269,7 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & 'Layer thicknesses tendency due to ALE regridding and remapping', 'm', & - conversion=GV%H_to_m, v_extensive = .true.) + conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) end subroutine ALE_register_diags @@ -319,7 +319,7 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, optional, intent(in) :: dt !< Time step between calls to ALE_main() + real, optional, intent(in) :: dt !< Time step between calls to ALE_main [T ~> s] real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions @@ -403,7 +403,7 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, optional, intent(in) :: dt !< Time step between calls to ALE_main() + real, optional, intent(in) :: dt !< Time step between calls to ALE_main [T ~> s] ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg-2] @@ -660,7 +660,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(tracer_registry_type), & optional, pointer :: Reg !< Tracer registry to remap onto new grid - real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding [s] + real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding [T ~> s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: dzRegrid !< Final change in interface positions logical, optional, intent(in) :: initial !< Whether we're being called from an initialization @@ -698,7 +698,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! Apply timescale to regridding (for e.g. filtered_grid_motion) if (present(dt)) & - call ALE_update_regrid_weights(dt, CS) + call ALE_update_regrid_weights(dt, CS) do k = 1, n call do_group_pass(pass_T_S_h, G%domain) @@ -718,7 +718,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg enddo ! remap all state variables (including those that weren't needed for regridding) - call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v, dt=dt) + call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) @@ -750,7 +750,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] logical, optional, intent(in) :: debug !< If true, show the call tree - real, optional, intent(in) :: dt !< time step for diagnostics + real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] ! Local variables integer :: i, j, k, m integer :: nz, ntr @@ -759,7 +759,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_conc real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_cont real, dimension(SZI_(G), SZJ_(G)) :: work_2d - real :: Idt, ppt2mks + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: ppt2mks real, dimension(GV%ke) :: h2 real :: h_neglect, h_neglect_edge logical :: show_call_tree @@ -1197,7 +1198,7 @@ end function ALE_remap_init_conds !> Updates the weights for time filtering the new grid generated in regridding subroutine ALE_update_regrid_weights( dt, CS ) - real, intent(in) :: dt !< Time-step used between ALE calls + real, intent(in) :: dt !< Time-step used between ALE calls [T ~> s] type(ALE_CS), pointer :: CS !< ALE control structure ! Local variables real :: w ! An implicit weighting estimate. diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 62fe0fe5f9..8d5ae130dd 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1221,9 +1221,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_ALE) if (use_ice_shelf) then call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, & - US%T_to_s*dtdia, fluxes%frac_shelf_h) + dtdia, fluxes%frac_shelf_h) else - call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, US%T_to_s*dtdia) + call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, dtdia) endif if (showCallTree) call callTree_waypoint("finished ALE_main (step_MOM_thermo)") @@ -2232,7 +2232,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! pass to the pointer shelf_area => frac_shelf_h call ALE_main(G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, & - CS%OBC, frac_shelf_h = shelf_area) + CS%OBC, frac_shelf_h=shelf_area) else call ALE_main( G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC) endif diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index da0b986303..f7c48778a0 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -158,7 +158,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! a restart file to the internal representation in this run. real :: vel_rescale ! A rescaling factor for velocities from the representation in ! a restart file to the internal representation in this run. - real :: dt ! The baroclinic dynamics timestep for this run [s]. + real :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. logical :: from_Z_file, useALE logical :: new_sim integer :: write_geom @@ -475,7 +475,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "an initial grid that is consistent with the initial conditions.", & default=1, do_not_log=just_read) - call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true.) + call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true., scale=US%s_to_T) if (new_sim .and. debug) & call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_m) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 52ad380273..7b9488cd62 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -354,7 +354,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock call MOM_tracer_chkinv(debug_msg, G, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call cpu_clock_begin(id_clock_ALE) - call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, CS%dt_offline) + call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, CS%US%s_to_T*CS%dt_offline) call cpu_clock_end(id_clock_ALE) if (CS%debug) then diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 663bfe1037..01d15fb887 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -546,18 +546,18 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) 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', conversion=US%s_to_T) 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) + diag%axesTL, Time, var_lname, flux_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) 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) + diag%axesT1, Time, var_lname, flux_units, conversion=Tr%conv_scale*US%s_to_T) endif From 0281e21fbaf5b1c7b51a8a7f528369babaf3784b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Nov 2019 08:57:19 -0500 Subject: [PATCH 222/259] +Pass timesteps to tracer column_physics in [T] Pass timesteps to the various tracer column_physics routines in [T] for dimensional consistency testing. Also added a new unit_scale_type argument to these routines. All answers are bitwise identical, but there are minor interface changes to 13 subroutines. --- .../vertical/MOM_diabatic_driver.F90 | 20 +++---- src/tracer/DOME_tracer.F90 | 11 ++-- src/tracer/ISOMIP_tracer.F90 | 12 ++-- src/tracer/MOM_OCMIP2_CFC.F90 | 17 +++--- src/tracer/MOM_offline_main.F90 | 18 +++--- src/tracer/MOM_tracer_flow_control.F90 | 58 +++++++++---------- src/tracer/RGC_tracer.F90 | 12 ++-- src/tracer/advection_test_tracer.F90 | 10 ++-- src/tracer/boundary_impulse_tracer.F90 | 12 ++-- src/tracer/dye_example.F90 | 7 ++- src/tracer/dyed_obc_tracer.F90 | 8 ++- src/tracer/ideal_age_example.F90 | 13 +++-- src/tracer/oil_tracer.F90 | 19 +++--- src/tracer/pseudo_salt_tracer.F90 | 8 ++- src/tracer/tracer_example.F90 | 6 +- 15 files changed, 127 insertions(+), 104 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index dca57e0a03..5117f693c2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1133,7 +1133,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied ! so hold should be h_orig - call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -1162,13 +1162,13 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim enddo ; enddo ; enddo ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -1807,7 +1807,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied ! so hold should be h_orig - call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -1831,13 +1831,13 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & minimum_forcing_depth = CS%minimum_forcing_depth) @@ -2642,7 +2642,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -2663,11 +2663,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eatr(i,j,k) = ea(i,j,k) + add_ent enddo ; enddo ; enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) else - call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) endif ! (CS%mix_boundary_tracers) @@ -2900,7 +2900,7 @@ subroutine adiabatic(h, tv, fluxes, dt, G, GV, US, CS) zeros(:,:,:) = 0.0 - call call_tracer_column_fns(h, h, zeros, zeros, fluxes, zeros(:,:,1), US%T_to_s*dt, G, GV, tv, & + call call_tracer_column_fns(h, h, zeros, zeros, fluxes, zeros(:,:,1), dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug) end subroutine adiabatic diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index debfd6f4b1..a97dd2776b 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -17,7 +17,7 @@ module DOME_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -143,7 +143,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & sponge_CSp, param_file) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -283,7 +283,7 @@ end subroutine initialize_DOME_tracer !! !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -301,7 +301,8 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to DOME_register_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -323,7 +324,7 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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(:,:,:,m) , dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index deb8669451..7e08b3c2ba 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -10,6 +10,7 @@ module ISOMIP_tracer ! Original sample tracer package by Robert Hallberg, 2002 ! Adapted to the ISOMIP test case by Gustavo Marques, May 2016 +use MOM_coms, only : max_across_PEs use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -17,15 +18,15 @@ 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_open_boundary, only : ocean_OBC_type 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 use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface -use MOM_open_boundary, only : ocean_OBC_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_coms, only : max_across_PEs use coupler_types_mod, only : coupler_type_set_data, ind_csurf use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux @@ -247,7 +248,7 @@ end subroutine initialize_ISOMIP_tracer !> This subroutine applies diapycnal diffusion, including the surface boundary !! conditions and any other column tracer physics or chemistry to the tracers from this file. -subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -265,7 +266,8 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to ISOMIP_register_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -312,7 +314,7 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, 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(:,:,:,m) , dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index a5fc04fc06..48b7966cef 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -406,7 +406,7 @@ end subroutine init_tracer_CFC !> This subroutine applies diapycnal diffusion, souces and sinks and any other column !! tracer physics or chemistry to the OCMIP2 CFC tracers. !! CFCs are relatively simple, as they are passive tracers with only a surface flux as a source. -subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -424,7 +424,8 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -470,19 +471,19 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS 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, CFC11, dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CFC11, US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) + call tracer_vertdiff(h_work, ea, eb, US%T_to_s*dt, CFC11, G, GV, sfc_flux=CFC11_flux) 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, CFC12, dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CFC12, US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) + call tracer_vertdiff(h_work, ea, eb, US%T_to_s*dt, CFC12, G, GV, sfc_flux=CFC12_flux) else - call tracer_vertdiff(h_old, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) - call tracer_vertdiff(h_old, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) + call tracer_vertdiff(h_old, ea, eb, US%T_to_s*dt, CFC11, G, GV, sfc_flux=CFC11_flux) + call tracer_vertdiff(h_old, ea, eb, US%T_to_s*dt, CFC12, G, GV, sfc_flux=CFC12_flux) endif ! Write out any desired diagnostics from tracer sources & sinks here. diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 7b9488cd62..a21456f722 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -726,8 +726,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e ! Note that tracerBoundaryFluxesInOut within this subroutine should NOT be called ! as the freshwater fluxes have already been accounted for - call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%dt_offline_vertical, CS%G, CS%GV, & - CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%US%s_to_T*CS%dt_offline_vertical, & + CS%G, CS%GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) if (CS%diurnal_SW .and. CS%read_sw) then fluxes%sw(:,:) = sw @@ -871,19 +871,23 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, temp_old, salt_old, & temp_mean, salt_mean, & zero_3dh ! - integer :: niter, iter - real :: Inum_iter, dt_iter - logical :: converged + integer :: niter, iter + real :: Inum_iter + real :: dt_iter ! The timestep of each iteration [T ~> s] + logical :: converged character(len=160) :: mesg ! The text of an error message integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y + G => CS%G ; GV => CS%GV 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 + dt_iter = CS%US%s_to_T * time_interval / real(max(1, CS%num_off_iter)) + do iter=1,CS%num_off_iter do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -907,7 +911,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! First do vertical advection call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & - fluxes, CS%mld, dt_iter, G, GV, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + fluxes, CS%mld, dt_iter, G, GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) ! We are now done with the vertical mass transports, so now h_new is h_sub do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 h_pre(i,j,k) = h_new(i,j,k) @@ -947,7 +951,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! Second vertical advection call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & - fluxes, CS%mld, dt_iter, G, GV, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + fluxes, CS%mld, dt_iter, G, GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) ! We are now done with the vertical mass transports, so now h_new is h_sub do k = 1, nz ; do i=is-1,ie+1 ; do j=js-1,je+1 h_pre(i,j,k) = h_new(i,j,k) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index d937f27d92..3153f360f2 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -408,7 +408,7 @@ subroutine call_tracer_set_forcing(state, fluxes, day_start, day_interval, G, CS end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. -subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, tv, optics, CS, & +subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, tv, optics, CS, & debug, evap_CFL_limit, minimum_forcing_depth) real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment !! [H ~> m or kg m-2]. @@ -425,10 +425,11 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, !! Unused fields have NULL ptrs. real, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [H ~> m or kg m-2] real, intent(in) :: dt !< The amount of time covered by this - !! call [s] + !! call [T ~> s] 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(optics_type), pointer :: optics !< The structure containing optical @@ -451,68 +452,68 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, ! Add calls to tracer column functions here. if (CS%use_USER_tracer_example) & call tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%USER_tracer_example_CSp) + G, GV, US, CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) & call DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%DOME_tracer_CSp, & + G, GV, US, CS%DOME_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ISOMIP_tracer) & call ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ISOMIP_tracer_CSp, & + G, GV, US, CS%ISOMIP_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_RGC_tracer) & call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%RGC_tracer_CSp, & + G, GV, US, CS%RGC_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ideal_age_tracer_CSp, & + G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dye_tracer_CSp, & + G, GV, US, CS%dye_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_oil) & call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%oil_tracer_CSp, tv, & + G, GV, US, CS%oil_tracer_CSp, tv, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_advection_test_tracer) & call advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%advection_test_tracer_CSp, & + G, GV, US, CS%advection_test_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_OCMIP2_CFC) & call OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%OCMIP2_CFC_CSp, & + G, GV, US, CS%OCMIP2_CFC_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, US%T_to_s*dt, & G, GV, CS%MOM_generic_tracer_CSp, tv, optics, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) #endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%pseudo_salt_tracer_CSp, tv, debug,& + G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_boundary_impulse_tracer) & call boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%boundary_impulse_tracer_CSp, tv, debug,& + G, GV, US, CS%boundary_impulse_tracer_CSp, tv, debug, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_dyed_obc_tracer) & call dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dyed_obc_tracer_CSp, & + G, GV, US, CS%dyed_obc_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) @@ -520,46 +521,45 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, else ! Apply tracer surface fluxes using ea on the first layer if (CS%use_USER_tracer_example) & call tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%USER_tracer_example_CSp) + G, GV, US, CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) & call DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%DOME_tracer_CSp) + G, GV, US, CS%DOME_tracer_CSp) if (CS%use_ISOMIP_tracer) & call ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ISOMIP_tracer_CSp) + G, GV, US, CS%ISOMIP_tracer_CSp) if (CS%use_RGC_tracer) & call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%RGC_tracer_CSp) + G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%ideal_age_tracer_CSp) + G, GV, US, CS%ideal_age_tracer_CSp) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dye_tracer_CSp) + G, GV, US, CS%dye_tracer_CSp) if (CS%use_oil) & call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%oil_tracer_CSp, tv) + G, GV, US, CS%oil_tracer_CSp, tv) if (CS%use_advection_test_tracer) & call advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%advection_test_tracer_CSp) + G, GV, US, CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) & call OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%OCMIP2_CFC_CSp) + G, GV, US, CS%OCMIP2_CFC_CSp) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, US%T_to_s*dt, & G, GV, CS%MOM_generic_tracer_CSp, tv, optics) #endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%pseudo_salt_tracer_CSp, tv, debug) + G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug) if (CS%use_boundary_impulse_tracer) & call boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%boundary_impulse_tracer_CSp, tv, debug) + G, GV, US, CS%boundary_impulse_tracer_CSp, tv, debug) if (CS%use_dyed_obc_tracer) & call dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, CS%dyed_obc_tracer_CSp) - + G, GV, US, CS%dyed_obc_tracer_CSp) endif diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index decb834a6a..3561c1ed45 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -26,6 +26,7 @@ module RGC_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_open_boundary, only : ocean_OBC_type use MOM_verticalGrid, only : verticalGrid_type @@ -275,7 +276,7 @@ end subroutine initialize_RGC_tracer !> This subroutine applies diapycnal diffusion and any other column !! tracer physics or chemistry to the tracers from this file. !! This is a simple example of a set of advected passive tracers. -subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -293,8 +294,9 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible !! forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s]. - type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can be !! fluxed out of the top layer in a timestep [nondim]. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes @@ -325,9 +327,9 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do m=1,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, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 12fd1e08a1..24059b6e23 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -16,6 +16,7 @@ module advection_test_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -257,7 +258,7 @@ end subroutine initialize_advection_test_tracer !> Applies diapycnal diffusion and any other column tracer physics or chemistry to the tracers !! from this package. This is a simple example of a set of advected passive tracers. -subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -275,8 +276,9 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] - type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] @@ -302,7 +304,7 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, 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(:,:,:,m) , dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index e712686521..b889c97d8c 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -17,6 +17,7 @@ module boundary_impulse_tracer use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -203,7 +204,7 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, end subroutine initialize_boundary_impulse_tracer !> Apply source or sink at boundary and do vertical diffusion -subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & tv, debug, evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -221,8 +222,9 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] - type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables @@ -256,7 +258,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, 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%tr(:,:,:,1), US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) else @@ -269,7 +271,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo - CS%remaining_source_time = CS%remaining_source_time-dt + CS%remaining_source_time = CS%remaining_source_time-US%T_to_s*dt else do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 0.0 diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 92f8491a49..27f96d840c 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -243,7 +243,7 @@ end subroutine initialize_dye_tracer !! This is a simple example of a set of advected passive tracers. !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -261,7 +261,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -288,7 +289,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS 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(:,:,:,m) , dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 4ea3611a2a..a601fc72c2 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -15,6 +15,7 @@ module dyed_obc_tracer use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -199,7 +200,7 @@ end subroutine initialize_dyed_obc_tracer !! !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -217,7 +218,8 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to dyed_obc_register_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -240,7 +242,7 @@ subroutine dyed_obc_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(:,:,:,m) , dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index a46e42f415..b54ca01c77 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -281,7 +281,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers -subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & +subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -299,7 +299,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -315,7 +316,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified real :: sfc_val ! The surface value for the tracers. - real :: Isecs_per_year ! The number of seconds in a year. + real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] real :: year ! The time in years. integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -328,7 +329,7 @@ subroutine ideal_age_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(:,:,:,m) , dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo @@ -338,10 +339,10 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo endif - Isecs_per_year = 1.0 / (365.0*86400.0) + Isecs_per_year = 1.0 / (365.0*86400.0*US%s_to_T) ! Set the surface value of tracer 1 to increase exponentially ! with a 30 year time scale. - year = time_type_to_real(CS%Time) * Isecs_per_year + year = US%s_to_T*time_type_to_real(CS%Time) * Isecs_per_year do m=1,CS%ntr if (CS%sfc_growth_rate(m) == 0.0) then diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 09fab89b70..2430790834 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -295,7 +295,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & end subroutine initialize_oil_tracer !> Apply sources, sinks, diapycnal mixing and rising motions to the oil tracers -subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, & +subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -313,7 +313,8 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables @@ -343,7 +344,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS 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(:,:,:,m) , dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo @@ -358,14 +359,14 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS ! Decay tracer (limit decay rate to 1/dt - just in case) do m=2,CS%ntr do k=1,nz ; do j=js,je ; do i=is,ie - !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - dt*CS%oil_decay_rate(m)*CS%tr(i,j,k,m) ! Simple - !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - min(dt*CS%oil_decay_rate(m),1.)*CS%tr(i,j,k,m) ! Safer + !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - US%T_to_s*dt*CS%oil_decay_rate(m)*CS%tr(i,j,k,m) ! Simple + !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - min(US%T_to_s*dt*CS%oil_decay_rate(m),1.)*CS%tr(i,j,k,m) ! Safer if (CS%oil_decay_rate(m)>0.) then - CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1.-dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - US%T_to_s*dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest elseif (CS%oil_decay_rate(m)<0.) then ldecay = 12.*(3.0**(-(tv%T(i,j,k)-20.)/10.)) ! Timescale [days] ldecay = 1./(86400.*ldecay) ! Rate [s-1] - CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1.-dt*ldecay,0.)*CS%tr(i,j,k,m) + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - US%T_to_s*dt*ldecay,0.)*CS%tr(i,j,k,m) endif enddo ; enddo ; enddo enddo @@ -383,7 +384,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS k=CS%oil_source_k(m) if (k>0) then k=min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / & + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*US%T_to_s*dt / & ((h_new(i,j,k)+GV%H_subroundoff) * G%US%L_to_m**2*G%areaT(i,j) ) elseif (k<0) then h_total=GV%H_subroundoff @@ -391,7 +392,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS h_total = h_total + h_new(i,j,k) enddo do k=1, nz - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt/(h_total & + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*US%T_to_s*dt/(h_total & * G%US%L_to_m**2*G%areaT(i,j) ) enddo endif diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index af4c1e9659..fd9d044758 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -19,6 +19,7 @@ module pseudo_salt_tracer use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -170,7 +171,7 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, end subroutine initialize_pseudo_salt_tracer !> Apply sources, sinks and diapycnal diffusion to the tracers in this package. -subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & +subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, debug, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -188,7 +189,8 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_pseudo_salt_tracer. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables @@ -225,7 +227,7 @@ 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%ps, dt, fluxes, h_work, & + call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, US%T_to_s*dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth, out_flux_optional=fluxes%netSalt) call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) else diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index aa9d34c4e1..c5e8f669c6 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -15,6 +15,7 @@ module USER_tracer_example use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -259,7 +260,7 @@ end subroutine USER_initialize_tracer !! This is a simple example of a set of advected passive tracers. !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) +subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS) 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)), & @@ -276,7 +277,8 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) !! added [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous !! call to USER_register_tracer_example. From b80d82e9d99ccf237781e95e687f3610c6b4e442 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Nov 2019 10:36:16 -0500 Subject: [PATCH 223/259] +Pass timesteps to applyTracerBoundaryFluxesInOut in [T] Pass timesteps to applyTracerBoundaryFluxesInOut in [T], and use units of [T-1] for internal source and decay rates for the oil tracer and in fluxes of CFCs. Also modified extract_offline_main to return timesteps as real values with units of [T]. Also there is a new unit_scale_type argument to register_oil_tracer. All answers in the MOM6_examples test cases and regression tests are bitwise identical. --- src/core/MOM.F90 | 21 ++++++------ src/tracer/DOME_tracer.F90 | 4 +-- src/tracer/ISOMIP_tracer.F90 | 4 +-- src/tracer/MOM_OCMIP2_CFC.F90 | 26 +++++++-------- src/tracer/MOM_generic_tracer.F90 | 5 ++- src/tracer/MOM_offline_main.F90 | 26 +++++++-------- src/tracer/MOM_tracer_diabatic.F90 | 7 ++-- src/tracer/MOM_tracer_flow_control.F90 | 26 ++++++--------- src/tracer/RGC_tracer.F90 | 4 +-- src/tracer/advection_test_tracer.F90 | 4 +-- src/tracer/boundary_impulse_tracer.F90 | 6 ++-- src/tracer/dye_example.F90 | 4 +-- src/tracer/dyed_obc_tracer.F90 | 4 +-- src/tracer/ideal_age_example.F90 | 4 +-- src/tracer/oil_tracer.F90 | 45 +++++++++++++------------- src/tracer/pseudo_salt_tracer.F90 | 4 +-- 16 files changed, 93 insertions(+), 101 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8d5ae130dd..27893a7a47 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1325,8 +1325,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: do_vertical !< If enough time has elapsed, do the diabatic tracer sources/sinks logical :: adv_converged !< True if all the horizontal fluxes have been used - real :: dt_off ! The offline timestep [T ~> s] - integer :: dt_offline, dt_offline_vertical + real :: dt_offline ! The offline timestep for advection [T ~> s] + real :: dt_offline_vertical ! The offline timestep for vertical fluxes and remapping [T ~> s] logical :: skip_diffusion integer :: id_eta_diff_end @@ -1354,7 +1354,6 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & dt_offline, dt_offline_vertical, skip_diffusion) Time_end = increment_date(Time_start, seconds=floor(time_interval+0.001)) - dt_off = US%s_to_T*REAL(dt_offline) call enable_averaging(time_interval, Time_end, CS%diag) @@ -1366,14 +1365,14 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif ! Check to see if vertical tracer functions should be done - if ( mod(accumulated_time, dt_offline_vertical) == 0 ) then + if ( mod(accumulated_time, floor(US%T_to_s*dt_offline_vertical + 1e-6)) == 0 ) then do_vertical = .true. else do_vertical = .false. endif ! Increment the amount of time elapsed since last read and check if it's time to roll around - accumulated_time = mod(accumulated_time + int(time_interval), dt_offline) + accumulated_time = mod(accumulated_time + int(time_interval), floor(US%T_to_s*dt_offline+1e-6)) if (accumulated_time==0) then last_iter = .true. else @@ -1406,9 +1405,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_off, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1431,9 +1430,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (associated(CS%VarMix)) then call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_off, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) endif - call tracer_hordiff(CS%h, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1459,7 +1458,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that ! exchange with the atmosphere - if (time_interval /= dt_offline) then + if (abs(time_interval - US%T_to_s*dt_offline) > 1.0e-6) then call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif @@ -1468,7 +1467,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS CS%h, eatr, ebtr, uhtr, vhtr) ! Perform offline diffusion if requested if (.not. skip_diffusion) then - call tracer_hordiff(h_end, dt_off, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h_end, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index a97dd2776b..9d9ec0ae73 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -324,8 +324,8 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + 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) enddo else diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 7e08b3c2ba..f41fd09dde 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -314,8 +314,8 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, 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(:,:,:,m) , US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + 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) enddo else diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 48b7966cef..0686fe0c1e 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -459,11 +459,11 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! These two calls unpack the fluxes from the input arrays. ! The -GV%Rho0 changes the sign convention of the flux and changes the units - ! of the flux from [Conc. m s-1] to [Conc. kg m-2 s-1]. - call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, ind_flux, & - CFC11_flux, -G%US%R_to_kg_m3*GV%Rho0, idim=idim, jdim=jdim) - call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, ind_flux, & - CFC12_flux, -G%US%R_to_kg_m3*GV%Rho0, idim=idim, jdim=jdim) + ! of the flux from [Conc. m s-1] to [Conc. kg m-2 T-1]. + call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, ind_flux, CFC11_flux, & + scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) + call coupler_type_extract_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, ind_flux, CFC12_flux, & + scale_factor=-G%US%R_to_kg_m3*GV%Rho0*US%T_to_s, idim=idim, jdim=jdim) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. @@ -471,19 +471,19 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US 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, CFC11, US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, US%T_to_s*dt, CFC11, G, GV, sfc_flux=CFC11_flux) + call applyTracerBoundaryFluxesInOut(G, GV, CFC11, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) 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, CFC12, US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, US%T_to_s*dt, CFC12, G, GV, sfc_flux=CFC12_flux) + call applyTracerBoundaryFluxesInOut(G, GV, CFC12, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) else - call tracer_vertdiff(h_old, ea, eb, US%T_to_s*dt, CFC11, G, GV, sfc_flux=CFC11_flux) - call tracer_vertdiff(h_old, ea, eb, US%T_to_s*dt, CFC12, G, GV, sfc_flux=CFC12_flux) + call tracer_vertdiff(h_old, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) + call tracer_vertdiff(h_old, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) endif ! Write out any desired diagnostics from tracer sources & sinks here. diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 28f31c6fa1..1d860a5521 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -507,8 +507,8 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, do k=1,nk ;do j=jsc,jec ; do i=isc,iec h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), G%US%s_to_T*dt, & + fluxes, h_work, evap_CFL_limit, minimum_forcing_depth) endif !traverse the linked list till hit NULL @@ -542,7 +542,6 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, call g_tracer_set_csdiag(CS%diag) #endif - end subroutine MOM_generic_tracer_column_physics !> This subroutine calculates mass-weighted integral on the PE either diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index a21456f722..ec18618648 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -116,8 +116,8 @@ module MOM_offline_main integer :: num_off_iter !< Number of advection iterations per offline step integer :: num_vert_iter !< Number of vertical iterations per offline step integer :: off_ale_mod !< Sets how frequently the ALE step is done during the advection - real :: dt_offline !< Timestep used for offline tracers [s] - real :: dt_offline_vertical !< Timestep used for calls to tracer vertical physics [s] + real :: dt_offline !< Timestep used for offline tracers [T ~> s] + real :: dt_offline_vertical !< Timestep used for calls to tracer vertical physics [T ~> s] real :: evap_CFL_limit !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes real :: minimum_forcing_depth !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity @@ -242,7 +242,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y - real :: evap_CFL_limit, minimum_forcing_depth, dt_iter, dt_offline + real :: evap_CFL_limit, minimum_forcing_depth + real :: dt_iter ! The timestep to use for each iteration [T ~> s] integer :: nstocks real :: stock_values(MAX_FIELDS_) @@ -260,13 +261,12 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - dt_offline = CS%dt_offline evap_CFL_limit = CS%evap_CFL_limit minimum_forcing_depth = CS%minimum_forcing_depth niter = CS%num_off_iter Inum_iter = 1./real(niter) - dt_iter = dt_offline*Inum_iter + dt_iter = CS%dt_offline*Inum_iter ! Initialize working arrays h_new(:,:,:) = 0.0 @@ -354,7 +354,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock call MOM_tracer_chkinv(debug_msg, G, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) endif call cpu_clock_begin(id_clock_ALE) - call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, CS%US%s_to_T*CS%dt_offline) + call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, CS%dt_offline) call cpu_clock_end(id_clock_ALE) if (CS%debug) then @@ -706,7 +706,7 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e enddo ; enddo do k=2,nz ; do j=js,je ; do i=is,ie hval=1.0/(CS%GV%H_subroundoff + 0.5*(h_pre(i,j,k-1) + h_pre(i,j,k))) - eatr(i,j,k) = (CS%GV%m_to_H**2) * CS%dt_offline_vertical * hval * CS%Kd(i,j,k) + eatr(i,j,k) = (CS%GV%m_to_H**2*CS%US%T_to_s) * CS%dt_offline_vertical * hval * CS%Kd(i,j,k) ebtr(i,j,k-1) = eatr(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -726,7 +726,7 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e ! Note that tracerBoundaryFluxesInOut within this subroutine should NOT be called ! as the freshwater fluxes have already been accounted for - call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%US%s_to_T*CS%dt_offline_vertical, & + call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%dt_offline_vertical, & CS%G, CS%GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) if (CS%diurnal_SW .and. CS%read_sw) then @@ -1207,9 +1207,9 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t !### Why are the following variables integers? integer, optional, pointer :: accumulated_time !< Length of time accumulated in the !! current offline interval [s] - integer, optional, intent( out) :: dt_offline !< Timestep used for offline tracers [s] - integer, optional, intent( out) :: dt_offline_vertical !< Timestep used for calls to tracer - !! vertical physics [s] + real, optional, intent( out) :: dt_offline !< Timestep used for offline tracers [T ~> s] + real, optional, intent( out) :: dt_offline_vertical !< Timestep used for calls to tracer + !! vertical physics [T ~> s] logical, optional, intent( out) :: skip_diffusion !< Skips horizontal diffusion of tracers ! Pointers to 3d members @@ -1324,11 +1324,11 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) call get_param(param_file, mdl, "NK_INPUT", CS%nk_input, & "Number of vertical levels in offline input files", default = nz) call get_param(param_file, mdl, "DT_OFFLINE", CS%dt_offline, & - "Length of time between reading in of input fields", fail_if_missing = .true.) + "Length of time between reading in of input fields", units='s', scale=US%s_to_T, fail_if_missing = .true.) call get_param(param_file, mdl, "DT_OFFLINE_VERTICAL", CS%dt_offline_vertical, & "Length of the offline timestep for tracer column sources/sinks " //& "This should be set to the length of the coupling timestep for " //& - "tracers which need shortwave fluxes", fail_if_missing = .true.) + "tracers which need shortwave fluxes", units="s", scale=US%s_to_T, fail_if_missing = .true.) call get_param(param_file, mdl, "START_INDEX", CS%start_index, & "Which time index to start from", default=1) call get_param(param_file, mdl, "FIELDS_ARE_OFFSET", CS%fields_are_offset, & diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 276742905c..e6319cb11e 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -231,7 +231,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim type(ocean_grid_type), intent(in ) :: G !< Grid structure type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Tr !< Tracer concentration on T-cell - real, intent(in ) :: dt !< Time-step over which forcing is applied [s] + real, intent(in ) :: dt !< Time-step over which forcing is applied [T ~> s] type(forcing), intent(in ) :: fluxes !< Surface fluxes container real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] real, intent(in ) :: evap_CFL_limit !< Limit on the fraction of the @@ -248,7 +248,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) - real :: H_limit_fluxes, IforcingDepthScale, Idt + real :: H_limit_fluxes, IforcingDepthScale real :: dThickness, dTracer real :: fractionOfForcing, hOld, Ithickness real :: RivermixConst ! A constant used in implementing river mixing [Pa s]. @@ -292,13 +292,12 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim update_h = .true. endif - Idt = 1.0/dt numberOfGroundings = 0 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,Tr,G,GV,fluxes,dt, & !$OMP IforcingDepthScale,minimum_forcing_depth, & !$OMP numberOfGroundings,iGround,jGround,update_h, & -!$OMP in_flux,out_flux,hGrounding,Idt,evap_CFL_limit) & +!$OMP in_flux,out_flux,hGrounding,evap_CFL_limit) & !$OMP private(h2d,Tr2d,netMassInOut,netMassOut, & !$OMP in_flux_1d,out_flux_1d,fractionOfForcing, & !$OMP dThickness,dTracer,hOld,Ithickness, & diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 3153f360f2..5a176cd3f9 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -143,9 +143,11 @@ subroutine call_tracer_flux_init(verbosity) end subroutine call_tracer_flux_init -!> The following 5 subroutines and associated definitions provide the -!! machinery to register and call the subroutines that initialize -!! tracers and apply vertical column processes to tracers. +! The following 5 subroutines and associated definitions provide the machinery to register and call +! the subroutines that initialize tracers and apply vertical column processes to tracers. + +!> This subroutine determines which tracer packages are to be used and does the calls to +!! register their tracers to be advected, diffused, and read from restarts. subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -159,18 +161,10 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! advection and diffusion module. type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control !! structure. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer that is set to point to the control structure -! for the tracer advection and diffusion module. -! (in) restart_CS - A pointer to the restart control structure. - -! This include declares and sets the variable "version". -#include "version_variable.h" + + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_flow_control" ! This module's name. if (associated(CS)) then @@ -251,7 +245,7 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) register_dye_tracer(HI, GV, US, param_file, CS%dye_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_oil) CS%use_oil = & - register_oil_tracer(HI, GV, param_file, CS%oil_tracer_CSp, & + register_oil_tracer(HI, GV, US, param_file, CS%oil_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_advection_test_tracer) CS%use_advection_test_tracer = & register_advection_test_tracer(HI, GV, param_file, CS%advection_test_tracer_CSp, & diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 3561c1ed45..d714c7f15d 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -329,8 +329,8 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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(:,:,:,m) , US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 24059b6e23..85d63f155e 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -304,8 +304,8 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, 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(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + 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) enddo else diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index b889c97d8c..411bd12696 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -51,7 +51,7 @@ module boundary_impulse_tracer real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land real :: kw_eff !< An effective piston velocity used to flux tracer out at the surface real :: remaining_source_time !< How much longer (same units as the timestep) to - !! inject the tracer at the surface + !! inject the tracer at the surface [s] type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -258,8 +258,8 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, 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), US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,1), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) else call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,1), G, GV) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 27f96d840c..efa9a74e74 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -289,8 +289,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US 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(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + 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) enddo else diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index a601fc72c2..2487b38d5c 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -242,8 +242,8 @@ subroutine dyed_obc_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(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index b54ca01c77..9ea25b0da2 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -329,8 +329,8 @@ subroutine ideal_age_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(:,:,:,m), US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + 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) enddo else diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 2430790834..965fb44450 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -45,7 +45,7 @@ module oil_tracer real :: oil_source_latitude !< Longitude of source location (geographic) integer :: oil_source_i=-999 !< Local i of source location (computational) integer :: oil_source_j=-999 !< Local j of source location (computational) - real :: oil_source_rate !< Rate of oil injection [kg s-1] + real :: oil_source_rate !< Rate of oil injection [kg T-1 ~> kg s-1] real :: oil_start_year !< The year in which tracers start aging, or at which the !! surface value equals young_val, in years. real :: oil_end_year !< The year in which tracers start aging, or at which the @@ -58,7 +58,7 @@ module oil_tracer real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] - real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [s-1] calculated from oil_decay_days + real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [T-1 ~> s-1] calculated from oil_decay_days integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code !! if they are not found in the restart files. @@ -74,16 +74,17 @@ module oil_tracer contains !> Register oil tracer fields and subroutines to be used with MOM. -function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) +function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control - !! structure for this module - type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control - !! structure for the tracer advection and - !! diffusion module - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure + type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! Local variables character(len=40) :: mdl = "oil_tracer" ! This module's name. @@ -139,7 +140,7 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "negative number for a vertically uniform source, "//& "or 0 not to use this tracer.", units="Layer", default=0) call get_param(param_file, mdl, "OIL_SOURCE_RATE", CS%oil_source_rate, & - "The rate of oil injection.", units="kg s-1", default=1.0) + "The rate of oil injection.", units="kg s-1", scale=US%T_to_s, default=1.0) call get_param(param_file, mdl, "OIL_DECAY_DAYS", CS%oil_decay_days, & "The decay timescale in days (if positive), or no decay "//& "if 0, or use the temperature dependent decay rate of "//& @@ -161,13 +162,13 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) 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)) + CS%oil_decay_rate(m) = 1. / (86400.0*US%s_to_T * CS%oil_decay_days(m)) elseif (CS%oil_decay_days(m)<0.) then - CS%oil_decay_rate(m)=-1. + CS%oil_decay_rate(m) = -1. endif endif enddo - call log_param(param_file, mdl, "OIL_DECAY_RATE", CS%oil_decay_rate(1:CS%ntr)) + call log_param(param_file, mdl, "OIL_DECAY_RATE", US%s_to_T*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" @@ -344,8 +345,8 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US 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(:,:,:,m) , US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) + 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) enddo else @@ -359,14 +360,14 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Decay tracer (limit decay rate to 1/dt - just in case) do m=2,CS%ntr do k=1,nz ; do j=js,je ; do i=is,ie - !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - US%T_to_s*dt*CS%oil_decay_rate(m)*CS%tr(i,j,k,m) ! Simple - !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - min(US%T_to_s*dt*CS%oil_decay_rate(m),1.)*CS%tr(i,j,k,m) ! Safer + !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - dt*CS%oil_decay_rate(m)*CS%tr(i,j,k,m) ! Simple + !CS%tr(i,j,k,m) = CS%tr(i,j,k,m) - min(dt*CS%oil_decay_rate(m),1.)*CS%tr(i,j,k,m) ! Safer if (CS%oil_decay_rate(m)>0.) then - CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - US%T_to_s*dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest elseif (CS%oil_decay_rate(m)<0.) then ldecay = 12.*(3.0**(-(tv%T(i,j,k)-20.)/10.)) ! Timescale [days] - ldecay = 1./(86400.*ldecay) ! Rate [s-1] - CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - US%T_to_s*dt*ldecay,0.)*CS%tr(i,j,k,m) + ldecay = 1. / (86400.*US%s_to_T * ldecay) ! Rate [T-1 ~> s-1] + CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*ldecay,0.)*CS%tr(i,j,k,m) endif enddo ; enddo ; enddo enddo @@ -384,7 +385,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US k=CS%oil_source_k(m) if (k>0) then k=min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*US%T_to_s*dt / & + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / & ((h_new(i,j,k)+GV%H_subroundoff) * G%US%L_to_m**2*G%areaT(i,j) ) elseif (k<0) then h_total=GV%H_subroundoff @@ -392,7 +393,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US h_total = h_total + h_new(i,j,k) enddo do k=1, nz - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*US%T_to_s*dt/(h_total & + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt/(h_total & * G%US%L_to_m**2*G%areaT(i,j) ) enddo endif diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index fd9d044758..a945f6462b 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -227,8 +227,8 @@ 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%ps, US%T_to_s*dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth, out_flux_optional=fluxes%netSalt) + call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth, out_flux_optional=fluxes%netSalt) call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) else call tracer_vertdiff(h_old, ea, eb, dt, CS%ps, G, GV) From a3b7adc40e4d8f7e9e3168e15debab4243273a6b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Nov 2019 13:30:09 -0500 Subject: [PATCH 224/259] Simplified expressions in MOM_PointAccel Simplified expressions inside of MOM_PointAccel, taking into account that all velocities use the same units of [L T-1]. All answers are bitwise identical. --- src/diagnostics/MOM_PointAccel.F90 | 62 ++++++++++++++---------------- 1 file changed, 29 insertions(+), 33 deletions(-) diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index dd72378671..276ba4e46e 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -58,7 +58,6 @@ module MOM_PointAccel real, pointer, dimension(:,:,:) :: pbce => NULL() !< pbce times eta gives the baroclinic !! pressure anomaly in each layer due to free surface height anomalies !! [m2 s-2 H-1 ~> m s-2 or m4 kg-1 s-2]. - real :: u_av_scale !< A scaling factor to convert u_av to m s-1. end type PointAccel_CS contains @@ -108,7 +107,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp Angstrom = GV%Angstrom_H + GV%H_subroundoff dt = US%T_to_s*dt_in_T - h_scale = GV%H_to_m ; uh_scale = GV%H_to_m + h_scale = GV%H_to_m ; uh_scale = GV%H_to_m*US%L_T_to_m_s ! if (.not.associated(CS)) return nz = G%ke @@ -134,14 +133,14 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp ! Determine which layers to write out accelerations for. do k=1,nz - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & + if (((max(CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & + if (((max(CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -171,7 +170,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%L_T_to_m_s*CS%u_prev(I,j,k)); enddo endif write(file,'(/,"u(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (CS%u_av_scale*CS%u_av(I,j,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%L_T_to_m_s*CS%u_av(I,j,k)); enddo write(file,'(/,"CFL u: ",$)') do k=ks,ke ; if (do_k(k)) then @@ -287,10 +286,10 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)); enddo + (uh_scale*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)); enddo write(file,'(/," vhC--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i,j-1,k)*h_scale*(hin(i,j-1,k) + hin(i,j,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i,j-1,k)*h_scale*(hin(i,j-1,k) + hin(i,j,k))); enddo if (prev_avail) then write(file,'(/," vhCp--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -299,10 +298,10 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i,J,k)*G%IdxCv(i,J)); enddo + (uh_scale*CDp%vh(i,J,k)*G%IdxCv(i,J)); enddo write(file,'(/," vhC-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i,J,k)*h_scale*(hin(i,j,k) + hin(i,j+1,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i,J,k)*h_scale*(hin(i,j,k) + hin(i,j+1,k))); enddo if (prev_avail) then write(file,'(/," vhCp-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -311,10 +310,10 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)); enddo + (uh_scale*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)); enddo write(file,'(/," vhC+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i+1,J-1,k)*h_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i+1,J-1,k)*h_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo if (prev_avail) then write(file,'(/," vhCp+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -323,14 +322,14 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"vh++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)); enddo + (uh_scale*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)); enddo write(file,'(/," vhC++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo if (prev_avail) then write(file,'(/," vhCp++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_av_scale*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo + (0.5*US%L_T_to_m_s*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo endif write(file,'(/,"D: ",2(ES10.3))') US%Z_to_m*G%bathyT(i,j),US%Z_to_m*G%bathyT(i+1,j) @@ -441,7 +440,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp Angstrom = GV%Angstrom_H + GV%H_subroundoff dt = US%T_to_s*dt_in_T - h_scale = GV%H_to_m ; uh_scale = GV%H_to_m + h_scale = GV%H_to_m ; uh_scale = GV%H_to_m*US%L_T_to_m_s ! if (.not.associated(CS)) return nz = G%ke @@ -466,14 +465,14 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp prev_avail = (associated(CS%u_prev) .and. associated(CS%v_prev)) do k=1,nz - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) <= -vel_rpt)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) >= vel_rpt) .or. & - (min(US%m_s_to_L_T*CS%u_av_scale*CS%v_av(i,J,k), US%L_T_to_m_s*vm(i,J,k)) <= -vel_rpt)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -505,7 +504,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp endif write(file,'(/,"v(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (CS%u_av_scale*CS%v_av(i,J,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%L_T_to_m_s*CS%v_av(i,J,k)); enddo write(file,'(/,"CFL v: ",$)') do k=ks,ke ; if (do_k(k)) then CFL = abs(vm(i,J,k)) * US%s_to_T*dt * G%dx_Cv(i,J) @@ -623,10 +622,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)); enddo + (uh_scale*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)); enddo write(file,'(/," uhC--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I-1,j,k) * h_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))); enddo + (US%L_T_to_m_s*CS%u_av(I-1,j,k) * h_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))); enddo if (prev_avail) then write(file,'(/," uhCp--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -635,10 +634,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)); enddo + (uh_scale*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)); enddo write(file,'(/," uhC-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I-1,j+1,k) * h_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo + (US%L_T_to_m_s*CS%u_av(I-1,j+1,k) * h_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo if (prev_avail) then write(file,'(/," uhCp-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -647,10 +646,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I,j,k)*G%IdyCu(I,j)); enddo + (uh_scale*CDp%uh(I,j,k)*G%IdyCu(I,j)); enddo write(file,'(/," uhC+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I,j,k) * h_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))); enddo + (US%L_T_to_m_s*CS%u_av(I,j,k) * h_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))); enddo if (prev_avail) then write(file,'(/," uhCp+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -659,10 +658,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp write(file,'(/,"uh++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (uh_scale*US%m_to_L*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)); enddo + (uh_scale*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)); enddo write(file,'(/," uhC++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av_scale*CS%u_av(I,j+1,k) * 0.5*h_scale*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo + (US%L_T_to_m_s*CS%u_av(I,j+1,k) * 0.5*h_scale*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo if (prev_avail) then write(file,'(/," uhCp++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & @@ -759,9 +758,6 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) CS%u_av => MIS%u_av; if (.not.associated(MIS%u_av)) CS%u_av => MIS%u(:,:,:) CS%v_av => MIS%v_av; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:) -! CS%u_av_scale = G%US%L_T_to_m_s ; if (.not.associated(MIS%u_av)) CS%u_av_scale = 1.0 - CS%u_av_scale = 1.0 - ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & From 2b0fea278284ee71e78ca39ffd2241b79261648c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Nov 2019 13:30:29 -0500 Subject: [PATCH 225/259] Corrected dimensional epsilons in downscaling Added distinct negligible volumes, face areas, horizonal areas and lengths with proper dimensional rescaling in the downsample field routines. With these changes, downscaled diagnostics should now pass the dimensional rescaling tests, whereas previously there would have been a problem when the numbers used to represent lengths are smaller than about 1e-8 times their MKS values. All answers are bitwise identical without dimensional rescaling. --- src/framework/MOM_diag_mediator.F90 | 99 ++++++++++++++++------------- 1 file changed, 56 insertions(+), 43 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index c82f3258b6..5fd21bd490 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -2982,13 +2982,15 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! This subroutine initializes the diag_mediator and the diag_manager. ! The grid type should have its dimensions set by this point, but it ! is not necessary that the metrics and axis labels be set up yet. + + ! Local variables integer :: ios, i, new_unit logical :: opened, new_file character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name. character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs @@ -3164,7 +3166,7 @@ end subroutine diag_mediator_init !> Set pointers to the default state fields used to remap diagnostics. subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) - real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array + real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array [H ~> m or kg m-2] real, dimension(:,:,:), target, intent(in ) :: T !< the model temperature array real, dimension(:,:,:), target, intent(in ) :: S !< the model salinity array type(EOS_type), target, intent(in ) :: eqn_of_state !< Equation of state structure @@ -3184,7 +3186,7 @@ subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure real, target, optional, intent(in ) :: alt_h(:,:,:) !< Used if remapped grids should be something other than - !! the current thicknesses + !! the current thicknesses [H ~> m or kg m-2] real, target, optional, intent(in ) :: alt_T(:,:,:) !< Used if remapped grids should be something other than !! the current temperatures real, target, optional, intent(in ) :: alt_S(:,:,:) !< Used if remapped grids should be something other than @@ -3862,9 +3864,15 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 integer :: k,ks,ke real :: ave,total_weight,weight - real :: epsilon = 1.0e-20 + real :: eps_vol ! A negligibly small volume or mass [H L2 ~> m3 or kg] + real :: eps_area ! A negligibly small area [L2 ~> m2] + real :: eps_face ! A negligibly small face area [H L ~> m2 or kg m-1] + + ks = 1 ; ke = size(field_in,3) + eps_face = 1.0e-20 * diag_cs%G%US%m_to_L * diag_cs%GV%m_to_H + eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 + eps_vol = 1.0e-20 * diag_cs%G%US%m_to_L**2 * diag_cs%GV%m_to_H - ks=1 ; ke =size(field_in,3) ! Allocate the down sampled field on the down sampled data domain ! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) @@ -3880,7 +3888,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d allocate(field_out(1:f1,1:f2,ks:ke)) ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain - if(method .eq. MMM) then + if (method == MMM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3888,24 +3896,24 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! - weight = mask(ii,jj,k)*diag_cs%G%US%L_to_m**2*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight + weight - ave=ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k) * weight enddo; enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. SSS) then !e.g., volcello + elseif (method == SSS) then !e.g., volcello do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 weight = mask(ii,jj,k) - ave=ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k)*weight enddo; enddo field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo - elseif(method .eq. MMP .or. method .eq. MMS) then !e.g., T_advection_xy + elseif(method == MMP .or. method == MMS) then !e.g., T_advection_xy do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3913,13 +3921,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj,k)*diag_cs%G%US%L_to_m**2*diag_cs%G%areaT(ii,jj) + weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight - ave=ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k)*weight enddo; enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PMM) then + elseif(method == PMM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3927,13 +3935,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj,k)*diag_cs%G%US%L_to_m*diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) + weight =mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight +weight ave=ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. PSS) then !e.g. umo + elseif(method == PSS) then !e.g. umo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3945,7 +3953,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo - elseif(method .eq. SPS) then !e.g. vmo + elseif(method == SPS) then !e.g. vmo do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3957,7 +3965,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d enddo field_out(i,j,k) = ave !Masked Sum (total_weight=1) enddo; enddo; enddo - elseif(method .eq. MPM) then + elseif(method == MPM) then do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -3965,13 +3973,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight = mask(ii,jj,k)*diag_cs%G%US%L_to_m*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) + weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight + weight ave=ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo; enddo - elseif(method .eq. MSK) then !The input field is a mask, subsample + elseif(method == MSK) then !The input field is a mask, subsample field_out(:,:,:) = 0.0 do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) @@ -4010,8 +4018,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d ! Locals character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 - real :: ave,total_weight,weight - real :: epsilon = 1.0e-20 + real :: ave, total_weight, weight + real :: epsilon = 1.0e-20 ! A negligibly small count of weights [nondim] + real :: eps_area ! A negligibly small area [L2 ~> m2] + real :: eps_len ! A negligibly small horizontal length [L ~> m] + + eps_len = 1.0e-20 * diag_cs%G%US%m_to_L + eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2 ! Allocate the down sampled field on the down sampled data domain ! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) @@ -4028,7 +4041,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d endif allocate(field_out(1:f1,1:f2)) - if(method .eq. MMP) then + if (method == MMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4036,13 +4049,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 ! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 - weight = mask(ii,jj)*diag_cs%G%US%L_to_m**2*diag_cs%G%areaT(ii,jj) + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight - ave=ave+field_in(ii,jj)*weight + ave = ave+field_in(ii,jj)*weight enddo; enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SSP) then ! e.g., T_dfxy_cont_tendency_2d + elseif(method == SSP) then ! e.g., T_dfxy_cont_tendency_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4056,7 +4069,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d enddo; enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. PSP) then ! e.g., umo_2d + elseif(method == PSP) then ! e.g., umo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4064,13 +4077,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight =mask(ii,jj) + weight = mask(ii,jj) total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. SPP) then ! e.g., vmo_2d + elseif(method == SPP) then ! e.g., vmo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4078,13 +4091,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight =mask(ii,jj) + weight = mask(ii,jj) total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. PMP) then + elseif(method == PMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4092,13 +4105,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 ii=i0 do jj=j0,j0+dl-1 - weight = mask(ii,jj)*diag_cs%G%US%L_to_m*diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. MPP) then + elseif(method == MPP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4106,13 +4119,13 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = 0.0 jj=j0 do ii=i0,i0+dl-1 - weight = mask(ii,jj)*diag_cs%G%US%L_to_m*diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? total_weight = total_weight +weight ave=ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 enddo; enddo - elseif(method .eq. MSK) then !The input field is a mask, subsample + elseif(method == MSK) then !The input field is a mask, subsample field_out(:,:) = 0.0 do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) From b48b594c5b5344b2361cab4d1c0ce7bb57e12e97 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Nov 2019 13:30:48 -0500 Subject: [PATCH 226/259] Simplified expressions in MOM_offline_aux Simplified expressions in distribute_residual_uh_barotropic. All answers are bitwise identical. --- src/tracer/MOM_offline_aux.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index d553af730d..0900598589 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -294,7 +294,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) endif ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - uh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i+1,j)) + uh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i+1,j)) if ( abs(sum(uh2d(I,:))-uh2d_sum(I)) > uh_neglect) & call MOM_error(WARNING,"Column integral of uh does not match after "//& "barotropic redistribution") @@ -364,7 +364,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) endif ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - vh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i,j+1)) + vh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i,j+1)) if ( abs(sum(vh2d(J,:))-vh2d_sum(J)) > vh_neglect) then call MOM_error(WARNING,"Column integral of vh does not match after "//& "barotropic redistribution") @@ -460,7 +460,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - uh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i+1,j)) + uh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i+1,j)) if (abs(uh_col - sum(uh2d(I,:)))>uh_neglect) then call MOM_error(WARNING,"Column integral of uh does not match after "//& "upwards redistribution") @@ -558,7 +558,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - vh_neglect = GV%Angstrom_H*min(G%US%L_to_m**2*G%areaT(i,j),G%US%L_to_m**2*G%areaT(i,j+1)) + vh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i,j+1)) if ( ABS(vh_col-SUM(vh2d(J,:))) > vh_neglect) then call MOM_error(WARNING,"Column integral of vh does not match after "//& "upwards redistribution") From 44cfd2724a272de80a60973d165bd42088f00c47 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Nov 2019 14:29:56 -0500 Subject: [PATCH 227/259] Revised wave_speed to return speed in [L T-1] Revised wave_speed to return the internal wave speed in units of [L T-1] and to use mono_N2_depth in units of [Z] for code simplification and expanded dimensional consistency testing. Also revised the internal units of some related diagnostics in calculate_diagnostic_fields. All answers and diagnostics are bitwise identical. --- src/diagnostics/MOM_diagnostics.F90 | 68 +++++++++---------- src/diagnostics/MOM_wave_speed.F90 | 14 ++-- .../lateral/MOM_lateral_mixing_coeffs.F90 | 10 ++- 3 files changed, 42 insertions(+), 50 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index d4fa0a59c8..ef55e456ac 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -52,7 +52,7 @@ module MOM_diagnostics !! monotonic for the purposes of calculating the equivalent !! barotropic wave speed. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [m]. + !! calculating the equivalent barotropic wave speed [Z ~> m]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -84,11 +84,11 @@ module MOM_diagnostics ! following fields are 2-D. real, pointer, dimension(:,:) :: & - cg1 => NULL(), & !< First baroclinic gravity wave speed [m s-1] - Rd1 => NULL(), & !< First baroclinic deformation radius [m] - cfl_cg1 => NULL(), & !< CFL for first baroclinic gravity wave speed, nondim - cfl_cg1_x => NULL(), & !< i-component of CFL for first baroclinic gravity wave speed, nondim - cfl_cg1_y => NULL() !< j-component of CFL for first baroclinic gravity wave speed, nondim + cg1 => NULL(), & !< First baroclinic gravity wave speed [L T-1 ~> m s-1] + Rd1 => NULL(), & !< First baroclinic deformation radius [L ~> m] + cfl_cg1 => NULL(), & !< CFL for first baroclinic gravity wave speed [nondim] + cfl_cg1_x => NULL(), & !< i-component of CFL for first baroclinic gravity wave speed [nondim] + cfl_cg1_y => NULL() !< j-component of CFL for first baroclinic gravity wave speed [nondim] ! The following arrays hold diagnostics in the layer-integrated energy budget. real, pointer, dimension(:,:,:) :: & @@ -219,29 +219,22 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! variable that gives the "correct" free surface height (Boussinesq) or total water column !! mass per unit area (non-Boussinesq). This is used to dilate the layer thicknesses when !! calculating interface heights [H ~> m or kg m-2]. + ! Local variables integer i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - ! coordinate variable potential density [R ~> 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)) + real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Coordinate variable potential density [R ~> kg m-3]. + real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) ! A 3-d temporary work array. + real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS real :: wt, wt_p - ! squared Coriolis parameter at to h-points [s-2] - real :: f2_h - - ! magnitude of the gradient of f [s-1 m-1] - real :: mag_beta - - ! frequency squared used to avoid division by 0 [s-2] - ! value is roughly (pi / (the age of the universe) )^2. - real, parameter :: absurdly_small_freq2 = 1e-34 + real :: f2_h ! Squared Coriolis parameter at to h-points [T-2 ~> s-2] + real :: mag_beta ! Magnitude of the gradient of f [T-1 L-1 ~> s-1 m-1] + real :: absurdly_small_freq2 ! Srequency squared used to avoid division by 0 [T-2 ~> s-2] integer :: k_list @@ -252,6 +245,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nz = G%ke ; nkmb = GV%nk_rho_varies + ! This value is roughly (pi / (the age of the universe) )^2. + absurdly_small_freq2 = 1e-34*US%T_to_s**2 + if (loc(CS)==0) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") @@ -317,7 +313,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call post_data(CS%id_masscello, work_3d, CS%diag) endif - ! mass of liquid ocean (for Bouss, use Rho0) + ! mass of liquid ocean (for Bouss, use Rho0). The reproducing sum requires the use of MKS units. if (CS%id_masso > 0) then work_2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie @@ -623,14 +619,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) if (CS%id_cg1>0) call post_data(CS%id_cg1, CS%cg1, CS%diag) if (CS%id_Rd1>0) then -!$OMP parallel do default(none) shared(is,ie,js,je,G,CS,US) & -!$OMP private(f2_h,mag_beta) + !$OMP parallel do default(shared) private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. - f2_h = absurdly_small_freq2 + 0.25 * US%s_to_T**2 * & + f2_h = absurdly_small_freq2 + 0.25 * & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - mag_beta = US%s_to_T*US%m_to_L * sqrt(0.5 * ( & + mag_beta = sqrt(0.5 * ( & (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & @@ -642,19 +637,19 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_cfl_cg1>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * (G%IdxT(i,j) + G%IdyT(i,j)) + CS%cfl_cg1(i,j) = (dt*CS%cg1(i,j)) * (G%IdxT(i,j) + G%IdyT(i,j)) enddo ; enddo call post_data(CS%id_cfl_cg1, CS%cfl_cg1, CS%diag) endif if (CS%id_cfl_cg1_x>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1_x(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * G%IdxT(i,j) + CS%cfl_cg1_x(i,j) = (dt*CS%cg1(i,j)) * G%IdxT(i,j) enddo ; enddo call post_data(CS%id_cfl_cg1_x, CS%cfl_cg1_x, CS%diag) endif if (CS%id_cfl_cg1_y>0) then do j=js,je ; do i=is,ie - CS%cfl_cg1_y(i,j) = (dt*US%m_s_to_L_T*CS%cg1(i,j)) * G%IdyT(i,j) + CS%cfl_cg1_y(i,j) = (dt*CS%cg1(i,j)) * G%IdyT(i,j) enddo ; enddo call post_data(CS%id_cfl_cg1_y, CS%cfl_cg1_y, CS%diag) endif @@ -672,14 +667,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_cg_ebt>0) call post_data(CS%id_cg_ebt, CS%cg1, CS%diag) if (CS%id_Rd_ebt>0) then -!$OMP parallel do default(none) shared(is,ie,js,je,G,CS,US) & -!$OMP private(f2_h,mag_beta) + !$OMP parallel do default(shared) private(f2_h,mag_beta) do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. - f2_h = absurdly_small_freq2 + 0.25 * US%s_to_T**2 * & + f2_h = absurdly_small_freq2 + 0.25 * & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - mag_beta = US%s_to_T*US%m_to_L * sqrt(0.5 * ( & + mag_beta = sqrt(0.5 * ( & (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & @@ -1481,7 +1475,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & - units='m', default=-1.) + units='m', scale=US%m_to_Z, default=-1.) if (GV%Boussinesq) then thickness_units = "m" ; flux_units = "m3 s-1" ; convert_H = GV%H_to_m @@ -1673,9 +1667,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag ! gravity wave CFLs CS%id_cg1 = register_diag_field('ocean_model', 'cg1', diag%axesT1, Time, & - 'First baroclinic gravity wave speed', 'm s-1') + 'First baroclinic gravity wave speed', 'm s-1', conversion=US%L_T_to_m_s) CS%id_Rd1 = register_diag_field('ocean_model', 'Rd1', diag%axesT1, Time, & - 'First baroclinic deformation radius', 'm') + 'First baroclinic deformation radius', 'm', conversion=US%L_to_m) CS%id_cfl_cg1 = register_diag_field('ocean_model', 'CFL_cg1', diag%axesT1, Time, & 'CFL of first baroclinic gravity wave = dt*cg1*(1/dx+1/dy)', 'nondim') CS%id_cfl_cg1_x = register_diag_field('ocean_model', 'CFL_cg1_x', diag%axesT1, Time, & @@ -1683,9 +1677,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_cfl_cg1_y = register_diag_field('ocean_model', 'CFL_cg1_y', diag%axesT1, Time, & 'j-component of CFL of first baroclinic gravity wave = dt*cg1*/dy', 'nondim') CS%id_cg_ebt = register_diag_field('ocean_model', 'cg_ebt', diag%axesT1, Time, & - 'Equivalent barotropic gravity wave speed', 'm s-1') + 'Equivalent barotropic gravity wave speed', 'm s-1', conversion=US%L_T_to_m_s) CS%id_Rd_ebt = register_diag_field('ocean_model', 'Rd_ebt', diag%axesT1, Time, & - 'Equivalent barotropic deformation radius', 'm') + 'Equivalent barotropic deformation radius', 'm', conversion=US%L_to_m) CS%id_p_ebt = register_diag_field('ocean_model', 'p_ebt', diag%axesTL, Time, & 'Equivalent barotropic modal strcuture', 'nondim') diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index c5915dae67..9b132fa5e3 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -54,7 +54,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [L T-1 ~> m s-1] type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire computational domain. @@ -65,7 +65,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & !! for the purposes of calculating vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical - !! modal structure [m]. + !! modal structure [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: modal_structure !< Normalized model structure [nondim] @@ -136,8 +136,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode l_mono_N2_column_fraction = CS%mono_N2_column_fraction if (present(mono_N2_column_fraction)) l_mono_N2_column_fraction = mono_N2_column_fraction - l_mono_N2_depth = US%m_to_Z*CS%mono_N2_depth - if (present(mono_N2_depth)) l_mono_N2_depth = US%m_to_Z*mono_N2_depth + l_mono_N2_depth = CS%mono_N2_depth + if (present(mono_N2_depth)) l_mono_N2_depth = mono_N2_depth calc_modal_structure = l_use_ebt_mode if (present(modal_structure)) calc_modal_structure = .true. if (calc_modal_structure) then @@ -464,7 +464,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & enddo cg1(i,j) = 0.0 - if (lam > 0.0) cg1(i,j) = 1.0 / sqrt(lam) + if (lam > 0.0) cg1(i,j) = US%m_s_to_L_T / sqrt(lam) if (present(modal_structure)) then if (mode_struct(1)/=0.) then ! Normalize @@ -1037,7 +1037,7 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure. + !! vertical modal structure [Z ~> m]. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_wave_speed" ! This module's name. @@ -1067,7 +1067,7 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure. + !! vertical modal structure [Z ~> m]. if (.not.associated(CS)) call MOM_error(FATAL, & "wave_speed_set_param called with an associated control structure.") diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 2fc6934de4..9e8dba4560 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -188,10 +188,6 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) endif - do j=js,je ; do i=is,ie - CS%cg1(i,j) = US%m_s_to_L_T*CS%cg1(i,j) - enddo ; enddo - call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) call do_group_pass(CS%pass_cg1, G%Domain) endif @@ -881,7 +877,9 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables - real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo, N2_filter_depth + real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo + real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when + ! calculating the first-mode wave speed [Z ~> m] real :: KhTr_passivity_coeff real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The ! default value is roughly (pi / (the age of the universe)). @@ -983,7 +981,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& "artifacts from altering the equivalent barotropic mode structure.",& - units="m", default=2000.) + units="m", default=2000., scale=US%m_to_Z) allocate(CS%ebt_struct(isd:ied,jsd:jed,G%ke)) ; CS%ebt_struct(:,:,:) = 0.0 endif From f8b75642113d3e5f7b94fce4a8eb246520ccee0f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 15 Nov 2019 11:35:02 -0500 Subject: [PATCH 228/259] Travis: Move regression tests to separate build This patch removes the regression test from the standard Travis job and moves it to a new job. We also run all regression tests before reporting the status code, and report a fail if any of the test give a different result. All files which have changed are reported at the end of the job. Code coverage tests have also been moved out of the invariance tests and into the regression testing. They continue to be based on symmetric grids. This test also combines the whitespace and documentation auditing into a a single test, in order to stay within 3 concurrent tests. --- .testing/Makefile | 21 ++++++++++++++++----- .travis.yml | 43 +++++++++++++++++++++++++++++-------------- 2 files changed, 45 insertions(+), 19 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index f032631123..8e6006457e 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -84,8 +84,9 @@ SOURCE = $(wildcard $(BASE)/src/*/*.F90 $(BASE)/src/*/*/*.F90 $(BASE)/config_src #--- # Rules -.PHONY: all +.PHONY: all build.regressions all: $(foreach b,$(BUILDS),$(BUILD)/$(b)/MOM6) +build.regressions: $(foreach b,symmetric target,$(BUILD)/$(b)/MOM6) # Executable BUILD_TARGETS = MOM6 Makefile path_names @@ -179,7 +180,6 @@ test: $(foreach t,$(TESTS),test.$(t)) # NOTE: We remove tc3 (OBC) from grid test since it cannot run asymmetric grids .PHONY: $(foreach t,$(TESTS),test.$(t)) -test.regressions: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) test.grids: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(c).grid $(c).grid.diag) test.layouts: $(foreach c,$(CONFIGS),$(c).layout $(c).layout.diag) test.restarts: $(foreach c,$(CONFIGS),$(c).restart) @@ -188,6 +188,9 @@ test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) test.dims: $(foreach c,$(CONFIGS),$(foreach d,t l h z,$(c).dim.$(d) $(c).dim.$(d).diag)) +test.regressions: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) + ! ls -1 results/*/*.reg + define CMP_RULE .PRECIOUS: $(foreach b,$(2),results/%/ocean.stats.$(b)) %.$(1): $(foreach b,$(2),results/%/ocean.stats.$(b)) @@ -198,7 +201,6 @@ define CMP_RULE cmp $$^ || diff $$^ endef -$(eval $(call CMP_RULE,regression,symmetric target)) $(eval $(call CMP_RULE,grid,symmetric asymmetric)) $(eval $(call CMP_RULE,layout,symmetric layout)) $(eval $(call CMP_RULE,repro,symmetric repro)) @@ -206,14 +208,23 @@ $(eval $(call CMP_RULE,openmp,symmetric openmp)) $(eval $(call CMP_RULE,nan,symmetric nan)) $(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) +# Custom comparison rules + +.PRECIOUS: $(foreach b,symmetric restart target,results/%/ocean.stats.$(b)) + # Restart tests only compare the final stat record -.PRECIOUS: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) -%.restart: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) +%.restart: $(foreach b,symmetric restart target,results/%/ocean.stats.$(b)) cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ || diff $^ # TODO: chksum_diag parsing of restart files +# All regression tests must be completed when considering answer changes +%.regression: $(foreach b,symmetric target,results/%/ocean.stats.$(b)) + cmp $^ || (diff $^ > $<.reg || true) + +%.regression.diag: $(foreach b,symmetric target,results/%/chksum_diag.$(b)) + cmp $^ || (diff $^ > $<.reg || true) #--- # Test run output files diff --git a/.travis.yml b/.travis.yml index 41d9d9b348..2cefbd8771 100644 --- a/.travis.yml +++ b/.travis.yml @@ -17,31 +17,46 @@ addons: packages: - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev openmpi-bin libopenmpi-dev gfortran - doxygen graphviz flex bison cmake + - python-numpy python-netcdf4 jobs: include: - - env: JOB="Code style compliance" + - env: JOB="Code compliance" script: + # Whitespace - ./.testing/trailer.py -e TEOS10 -l 120 src config_src - - env: JOB="Doxygen" - script: + # API Documentation - cd docs && doxygen Doxyfile_nortd - grep -v "config_src/solo_driver/coupler_types.F90" doxygen.log | tee doxy_errors - test ! -s doxy_errors - - env: JOB="Compile and run" + + - env: + - JOB="Configuration testing" + - DO_REGRESSION_TESTS=false + - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk script: + - cd .testing - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - TRAVIS_IS_PR=$( [ ${TRAVIS_PULL_REQUEST} = "false" ] || echo "true" ) + - make all + - echo -en 'travis_fold:end:script.1\\r' + - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' + - make test + - echo -en 'travis_fold:end:script.2\\r' + + # NOTE: Code coverage upload is here to reduce load imbalance + - if: type = pull_request + env: + - JOB="Regression testing" + - DO_REGRESSION_TESTS=true + - REPORT_COVERAGE=true + - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk + - MOM_TARGET_SLUG=${TRAVIS_REPO_SLUG} + - MOM_TARGET_LOCAL_BRANCH=${TRAVIS_BRANCH} + script: - cd .testing - - make \ - MKMF_TEMPLATE=linux-ubuntu-xenial-gnu.mk \ - MOM_TARGET_SLUG=${TRAVIS_REPO_SLUG} \ - MOM_TARGET_LOCAL_BRANCH=${TRAVIS_BRANCH} \ - DO_REGRESSION_TESTS=${TRAVIS_IS_PR} \ - REPORT_COVERAGE=true + - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' + - make build.regressions - echo -en 'travis_fold:end:script.1\\r' - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' - - make test \ - DO_REGRESSION_TESTS=${TRAVIS_IS_PR} \ - REPORT_COVERAGE=true + - make test.regressions - echo -en 'travis_fold:end:script.2\\r' From 558b5e08a6d754e28cace090bb280c4c7ae23043 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 15 Nov 2019 11:51:58 -0500 Subject: [PATCH 229/259] Testing: Makefile typo --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 8e6006457e..66247a252a 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -213,7 +213,7 @@ $(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) .PRECIOUS: $(foreach b,symmetric restart target,results/%/ocean.stats.$(b)) # Restart tests only compare the final stat record -%.restart: $(foreach b,symmetric restart target,results/%/ocean.stats.$(b)) +%.restart: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ || diff $^ From 05b136b2c113f3b0cd1c9bc1cc06b46bc7ff8b4d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Nov 2019 13:23:50 -0500 Subject: [PATCH 230/259] Rescaled internal variables in wave_speed Rescale internal calculations in wave_speed and wave_speeds for greater robustness and dimensional consistency testing. All answers are bitwise identical and pass dimensional scaling tests. --- src/diagnostics/MOM_wave_speed.F90 | 183 +++++++++++++++++------------ 1 file changed, 106 insertions(+), 77 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 9b132fa5e3..db65068c52 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -76,11 +76,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & pres, & ! Interface pressure [Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] - gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. + gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu, Igd ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it. - ! Their sum, Igd, is provided for the tridiagonal solver. [s2 m-2] + ! Their sum, Igd, is provided for the tridiagonal solver. [T2 L-2 ~> s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -92,9 +92,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] - real det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 - real :: lam, dlam, lam0 - real :: min_h_frac + real :: det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 + real :: lam ! The eigenvalue [T2 L-2 ~> s m-1] + real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] + real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s m-1] + real :: min_h_frac ! [nondim] real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) real, dimension(SZI_(G)) :: & htot, hmin, & ! Thicknesses [Z ~> m] @@ -102,13 +104,16 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] HxR_here ! A layer integrated density [R Z ~> kg m-2] - real :: speed2_tot ! overestimate of the mode-1 speed squared [m2 s-2] + real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] - real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 m-2 ~> 1]. + real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 L-2 ~> 1]. real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant + ! and its derivative with lam between rows of the Thomas algorithm solver. The + ! exact value should not matter for the final result if it is an even power of 2. real :: rescale, I_rescale integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 @@ -117,7 +122,9 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! equation of state. integer :: kc integer :: i, j, k, k2, itt, is, ie, js, je, nz - real :: hw, gp, sum_hc, N2min + real :: hw, sum_hc + real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] + real :: N2min ! A minimum buoyancy frequency [T-2 ~> s-2] logical :: l_use_ebt_mode, calc_modal_structure real :: l_mono_N2_column_fraction, l_mono_N2_depth real :: mode_struct(SZK_(G)), ms_min, ms_max, ms_sq @@ -130,7 +137,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed endif ; endif - L2_to_Z2 = US%m_to_Z**2 + L2_to_Z2 = US%L_to_Z**2 l_use_ebt_mode = CS%use_ebt_mode if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode @@ -147,11 +154,14 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 Z_to_Pa = GV%Z_to_H * GV%H_to_Pa use_EOS = associated(tv%eqn_of_state) rescale = 1024.0**4 ; I_rescale = 1.0/rescale + ! The following two lines give identical results: + ! c2_scale = 16.0 * US%m_s_to_L_T**2 + c2_scale = US%m_s_to_L_T**2 min_h_frac = tol1 / real(nz) !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S,tv,& @@ -345,7 +355,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & (L2_to_Z2*gp > N2min*hw) ) then ! Filters out regions where N2 increases with depth but only in a lower fraction ! of the water column or below a certain depth. - gp = US%Z_to_m**2 * (N2min*hw) + gp = US%Z_to_L**2 * (N2min*hw) else N2min = L2_to_Z2 * gp/hw endif @@ -384,13 +394,14 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! | igu(2) b(2)-lam igl(2) 0 0 ... | ! | 0 igu(3) b(3)-lam igl(3) 0 ... | ! which is consistent if the eigenvalue problem is for horizontal velocity or pressure modes. - !detKm1 = ( Igl(1)-lam) ; ddetKm1 = -1.0 + !detKm1 = c2_scale*(Igl(1)-lam) ; ddetKm1 = -1.0*c2_scale !det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1)) ; ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - detKm1 detKm1 = 1.0 ; ddetKm1 = 0.0 - det = ( Igl(1)-lam) ; ddet = -1.0 + det = (Igl(1)-lam) ; ddet = -1.0 if (kc>1) then - detKm2 = detKm1; ddetKm2 = ddetKm1 - detKm1 = det; ddetKm1 = ddet + ! Shift variables and rescale rows to avoid over- or underflow. + detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 + detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet det = (Igu(2)+Igl(2)-lam)*detKm1 - (Igu(2)*Igl(1))*detKm2 ddet = (Igu(2)+Igl(2)-lam)*ddetKm1 - (Igu(2)*Igl(1))*ddetKm2 - detKm1 endif @@ -405,23 +416,27 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! | 0 igu43) b(4)-lam igl(4) 0 ... | ! which is consistent if the eigenvalue problem is for vertical velocity modes. detKm1 = 1.0 ; ddetKm1 = 0.0 - det = (Igu(2)+Igl(2)-lam) ; ddet = -1.0 + det = (Igu(2) + Igl(2) - lam) ; ddet = -1.0 ! The last three rows of the w equation matrix are ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) 0 | ! | ... 0 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 0 igu(kc) b(kc)-lam / endif do k=3,kc - detKm2 = detKm1; ddetKm2 = ddetKm1 - detKm1 = det; ddetKm1 = ddet + ! Shift variables and rescale rows to avoid over- or underflow. + detKm2 = c2_scale*detKm1 ; ddetKm2 = c2_scale*ddetKm1 + detKm1 = c2_scale*det ; ddetKm1 = c2_scale*ddet det = (Igu(k)+Igl(k)-lam)*detKm1 - (Igu(k)*Igl(k-1))*detKm2 ddet = (Igu(k)+Igl(k)-lam)*ddetKm1 - (Igu(k)*Igl(k-1))*ddetKm2 - detKm1 - ! Rescale det & ddet if det is getting too large. + ! Rescale det & ddet if det is getting too large or too small. if (abs(det) > rescale) then det = I_rescale*det ; detKm1 = I_rescale*detKm1 ddet = I_rescale*ddet ; ddetKm1 = I_rescale*ddetKm1 + elseif (abs(det) < I_rescale) then + det = rescale*det ; detKm1 = rescale*detKm1 + ddet = rescale*ddet ; ddetKm1 = rescale*ddetKm1 endif enddo ! Use Newton's method iteration to find a new estimate of lam. @@ -464,7 +479,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & enddo cg1(i,j) = 0.0 - if (lam > 0.0) cg1(i,j) = US%m_s_to_L_T / sqrt(lam) + if (lam > 0.0) cg1(i,j) = 1.0 / sqrt(lam) if (present(modal_structure)) then if (mode_struct(1)/=0.) then ! Normalize @@ -498,14 +513,17 @@ end subroutine wave_speed !! This uses the Thomas algorithm rather than the Hallberg algorithm since the matrix is not symmetric. subroutine tdma6(n, a, b, c, lam, y) integer, intent(in) :: n !< Number of rows of matrix - real, dimension(n), intent(in) :: a !< Lower diagonal - real, dimension(n), intent(in) :: b !< Leading diagonal - real, dimension(n), intent(in) :: c !< Upper diagonal - real, intent(in) :: lam !< Scalar subtracted from leading diagonal + real, dimension(n), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] + real, dimension(n), intent(in) :: b !< Leading diagonal [T2 L-2 ~> s2 m-2] + real, dimension(n), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] + real, intent(in) :: lam !< Scalar subtracted from leading diagonal [T2 L-2 ~> s2 m-2] real, dimension(n), intent(inout) :: y !< RHS on entry, result on exit ! Local variables integer :: k, l - real :: beta(n), yy(n), lambda + real :: beta(n), lambda ! Temporary variables in [T2 L-2 ~> s2 m-2] + real :: I_beta(n) ! Temporary variables in [L2 T-2 ~> m2 s-2] + real :: yy(n) ! A temporary variable with the same units as y on entry. + lambda = lam beta(1) = b(1) - lambda if (beta(1)==0.) then ! lam was chosen too perfectly @@ -513,26 +531,28 @@ subroutine tdma6(n, a, b, c, lam, y) lambda = (1. + 1.e-5) * lambda beta(1) = b(1) - lambda endif - beta(1) = 1. / beta(1) + I_beta(1) = 1. / beta(1) yy(1) = y(1) do k = 2, n - beta(k) = ( b(k) - lambda ) - a(k) * c(k-1) * beta(k-1) + beta(k) = ( b(k) - lambda ) - a(k) * c(k-1) * I_beta(k-1) + ! Perhaps the following 0 needs to become a tolerance to handle underflow? if (beta(k)==0.) then ! lam was chosen too perfectly ! Change lambda and redo everything up to row k lambda = (1. + 1.e-5) * lambda - beta(1) = 1. / ( b(1) - lambda ) + I_beta(1) = 1. / ( b(1) - lambda ) do l = 2, k - beta(l) = 1. / ( ( b(l) - lambda ) - a(l) * c(l-1) * beta(l-1) ) - yy(l) = y(l) - a(l) * yy(l-1) * beta(l-1) + I_beta(l) = 1. / ( ( b(l) - lambda ) - a(l) * c(l-1) * I_beta(l-1) ) + yy(l) = y(l) - a(l) * yy(l-1) * I_beta(l-1) enddo else - beta(k) = 1. / beta(k) + I_beta(k) = 1. / beta(k) endif - yy(k) = y(k) - a(k) * yy(k-1) * beta(k-1) + yy(k) = y(k) - a(k) * yy(k-1) * I_beta(k-1) enddo - y(n) = yy(n) * beta(n) + ! The units of y change by a factor of [L2 T-2] in the following lines. + y(n) = yy(n) * I_beta(n) do k = n-1, 1, -1 - y(k) = ( yy(k) - c(k) * y(k+1) ) * beta(k) + y(k) = ( yy(k) - c(k) * y(k+1) ) * I_beta(k) enddo end subroutine tdma6 @@ -555,14 +575,14 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) pres, & ! Interface pressure [Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] - gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. + gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. + ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(G)-1) :: & a_diag, b_diag, c_diag ! diagonals of tridiagonal matrix; one value for each - ! interface (excluding surface and bottom) + ! interface (excluding surface and bottom) [T2 L-2 ~> s2 m-2] real, dimension(SZK_(G),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [degC] @@ -573,23 +593,22 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] - real, parameter :: c1_thresh = 0.01 - ! if c1 is below this value, don't bother calculating - ! cn values for higher modes + real :: c1_thresh ! if c1 is below this value, don't bother calculating + ! cn values for higher modes [L T-1 ~> m s-1] real :: det, ddet ! determinant & its derivative of eigen system - real :: lam_1 ! approximate mode-1 eigen value - real :: lam_n ! approximate mode-n eigen value - real :: dlam ! increment in lam for Newton's method - real :: lamMin ! minimum lam value for root searching range - real :: lamMax ! maximum lam value for root searching range - real :: lamInc ! width of moving window for root searching + real :: lam_1 ! approximate mode-1 eigenvalue [T2 L-2 ~> s2 m-2] + real :: lam_n ! approximate mode-n eigenvalue [T2 L-2 ~> s2 m-2] + real :: dlam ! increment in lam for Newton's method [T2 L-2 ~> s2 m-2] + real :: lamMin ! minimum lam value for root searching range [T2 L-2 ~> s2 m-2] + real :: lamMax ! maximum lam value for root searching range [T2 L-2 ~> s2 m-2] + real :: lamInc ! width of moving window for root searching [T2 L-2 ~> s2 m-2] real :: det_l,det_r ! determinant value at left and right of window real :: ddet_l,ddet_r ! derivative of determinant at left and right of window real :: det_sub,ddet_sub! derivative of determinant at subinterval endpoint - real :: xl,xr ! lam guesses at left and right of window - real :: xl_sub ! lam guess at left of subinterval window + real :: xl,xr ! lam guesses at left and right of window [T2 L-2 ~> s2 m-2] + real :: xl_sub ! lam guess at left of subinterval window [T2 L-2 ~> s2 m-2] real,dimension(nmodes) :: & - xbl,xbr ! lam guesses bracketing a zero-crossing (root) + xbl,xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) real :: min_h_frac @@ -600,20 +619,20 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] HxR_here ! A layer integrated density [R Z ~> kg m-2] - real :: speed2_tot ! overestimate of the mode-1 speed squared [m2 s-2] - real :: speed2_min ! minimum mode speed (squared) to consider in root searching + real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] + real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] real, parameter :: reduct_factor = 0.5 - ! factor used in setting speed2_min + ! factor used in setting speed2_min [nondim] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [m2 s-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. real, dimension(SZK_(G)+1) :: z_int - ! real, dimension(SZK_(G)+1) :: N2 + ! real, dimension(SZK_(G)+1) :: N2 ! The local squared buoyancy frequency [T-2 ~> s-2] integer :: nsub ! number of subintervals used for root finding integer, parameter :: sub_it_max = 4 ! maximum number of times to subdivide interval @@ -635,9 +654,10 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif ; endif S => tv%S ; T => tv%T - g_Rho0 = US%L_T_to_m_s**2 * GV%g_Earth / GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) Z_to_Pa = GV%Z_to_H * GV%H_to_Pa + c1_thresh = 0.01*US%m_s_to_L_T min_h_frac = tol1 / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & @@ -814,7 +834,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) z_int(K) = z_int(K-1) + Hc(k-1) - ! N2(K) = US%m_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) + ! N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) enddo ! Set stratification for surface and bottom (setting equal to nearest interface for now) @@ -830,31 +850,31 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! First, populate interior rows do K=3,kc-1 row = K-1 ! indexing for TD matrix rows - a_diag(row) = (-Igu(K)) - b_diag(row) = (Igu(K)+Igl(K)) - c_diag(row) = (-Igl(K)) + a_diag(row) = -Igu(K) + b_diag(row) = Igu(K)+Igl(K) + c_diag(row) = -Igl(K) enddo ! Populate top row of tridiagonal matrix K=2 ; row = K-1 a_diag(row) = 0.0 - b_diag(row) = (Igu(K)+Igl(K)) - c_diag(row) = (-Igl(K)) + b_diag(row) = Igu(K)+Igl(K) + c_diag(row) = -Igl(K) ! Populate bottom row of tridiagonal matrix K=kc ; row = K-1 - a_diag(row) = (-Igu(K)) - b_diag(row) = (Igu(K)+Igl(K)) + a_diag(row) = -Igu(K) + b_diag(row) = Igu(K)+Igl(K) c_diag(row) = 0.0 ! Total number of rows in the matrix = number of interior interfaces nrows = kc-1 - ! Under estimate the first eigen value to start with. + ! Under estimate the first eigenvalue to start with. lam_1 = 1.0 / speed2_tot ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_1,det,ddet) + nrows,lam_1,det,ddet, row_scale=US%m_s_to_L_T**2) ! Use Newton's method iteration to find a new estimate of lam_1 !det = det_it(itt) ; ddet = ddet_it(itt) if ((ddet >= 0.0) .or. (-det > -0.5*lam_1*ddet)) then @@ -892,13 +912,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! find det_l of first interval (det at left endpoint) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lamMin,det_l,ddet_l) + nrows,lamMin,det_l,ddet_l, row_scale=US%m_s_to_L_T**2) ! move interval window looking for zero-crossings************************ do iint=1,numint xr = lamMin + lamInc * iint xl = xr - lamInc call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xr,det_r,ddet_r) + nrows,xr,det_r,ddet_r, row_scale=US%m_s_to_L_T**2) if (det_l*det_r < 0.0) then ! if function changes sign if (det_l*ddet_l < 0.0) then ! if function at left is headed to zero nrootsfound = nrootsfound + 1 @@ -919,7 +939,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7;... xl_sub = xl + lamInc/(nsub)*sub call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xl_sub,det_sub,ddet_sub) + nrows,xl_sub,det_sub,ddet_sub, row_scale=US%m_s_to_L_T**2) if (det_sub*det_r < 0.0) then ! if function changes sign if (det_sub*ddet_sub < 0.0) then ! if function at left is headed to zero sub_rootfound = .true. @@ -962,7 +982,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do itt=1,max_itt ! calculate the determinant of (A-lam_n*I) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_n,det,ddet) + nrows,lam_n,det,ddet, row_scale=US%m_s_to_L_T**2) ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam @@ -976,7 +996,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) else cn(i,j,2:nmodes) = 0.0 ! else too small to worry about endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh - do m=1,nmodes ; cn(i,j,m) = US%m_s_to_L_T*cn(i,j,m) ; enddo else cn(i,j,:) = 0.0 endif ! if more than 2 layers @@ -989,8 +1008,11 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) end subroutine wave_speeds -!> Calculate the determinant of a tridiagonal matrix with diagonals a,b-lam,c where lam is constant across rows. -subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) +!> Calculate the determinant of a tridiagonal matrix with diagonals a,b-lam,c and its derivative +!! with lam, where lam is constant across rows. Only the ratio of det to its derivative and their +!! signs are typically used, so internal rescaling by consistent factors are used to avoid +!! over- or underflow. +subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry = 0) real, dimension(:), intent(in) :: b !< Leading diagonal of matrix (excluding lam) real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry = 0) @@ -998,10 +1020,13 @@ subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) real, intent(in) :: lam !< Value subtracted from b real, intent(out):: det_out !< Determinant real, intent(out):: ddet_out !< Derivative of determinant w.r.t. lam + real, optional, intent(in) :: row_scale !< A scaling factor of the rows of the + !! matrix to limit the growth of the determinant ! Local variables real, dimension(nrows) :: det ! value of recursion function real, dimension(nrows) :: ddet ! value of recursion function for derivative real, parameter:: rescale = 1024.0**4 ! max value of determinant allowed before rescaling + real :: rscl real :: I_rescale ! inverse of rescale integer :: n ! row (layer interface) index @@ -1010,20 +1035,24 @@ subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") I_rescale = 1.0/rescale + rscl = 1.0 ; if (present(row_scale)) rscl = row_scale det(1) = 1.0 ; ddet(1) = 0.0 det(2) = b(2)-lam ; ddet(2) = -1.0 do n=3,nrows - det(n) = (b(n)-lam)*det(n-1) - (a(n)*c(n-1))*det(n-2) - ddet(n) = (b(n)-lam)*ddet(n-1) - (a(n)*c(n-1))*ddet(n-2) - det(n-1) - ! Rescale det & ddet if det is getting too large. + det(n) = rscl*(b(n)-lam)*det(n-1) - rscl*(a(n)*c(n-1))*det(n-2) + ddet(n) = rscl*(b(n)-lam)*ddet(n-1) - rscl*(a(n)*c(n-1))*ddet(n-2) - det(n-1) + ! Rescale det & ddet if det is getting too large or too small to avoid overflow or underflow. if (abs(det(n)) > rescale) then det(n) = I_rescale*det(n) ; det(n-1) = I_rescale*det(n-1) ddet(n) = I_rescale*ddet(n) ; ddet(n-1) = I_rescale*ddet(n-1) + elseif (abs(det(n)) < I_rescale) then + det(n) = rescale*det(n) ; det(n-1) = rescale*det(n-1) + ddet(n) = rescale*ddet(n) ; ddet(n-1) = rescale*ddet(n-1) endif enddo det_out = det(nrows) - ddet_out = ddet(nrows) + ddet_out = ddet(nrows) / rscl end subroutine tridiag_det From 6e115b77f33d85e3e9bc8ab64a678b44113da23a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Nov 2019 15:28:11 -0500 Subject: [PATCH 231/259] +Changed the units of minimum_forcing_depth to [H] Changed the units of minimum_forcing_depth passed to applyBoundaryFluxesInOut and applyTracerBoundaryFluxesInOut to [H]. All answers are bitwise identical. --- .../vertical/MOM_diabatic_aux.F90 | 4 ++-- .../vertical/MOM_diabatic_driver.F90 | 20 +++++++++---------- src/tracer/DOME_tracer.F90 | 3 +-- src/tracer/ISOMIP_tracer.F90 | 2 +- src/tracer/MOM_OCMIP2_CFC.F90 | 2 +- src/tracer/MOM_generic_tracer.F90 | 3 ++- src/tracer/MOM_offline_main.F90 | 12 ++++++++--- src/tracer/MOM_tracer_diabatic.F90 | 4 ++-- src/tracer/RGC_tracer.F90 | 2 +- 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 +- 16 files changed, 36 insertions(+), 30 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3e2588db8c..853b6f57c2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -867,7 +867,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t real, intent(in) :: evap_CFL_limit !< The largest fraction of a layer that !! can be evaporated in one time-step [nondim]. real, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! heat and freshwater fluxes is applied [m]. + !! heat and freshwater fluxes is applied [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: cTKE !< Turbulent kinetic energy requirement to mix !! forcing through each layer [R Z3 T-2 ~> J m-2] @@ -1168,7 +1168,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute ! forcing into deeper layers. - IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth*GV%m_to_H - netMassOut(i) ) + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) ! fractionOfForcing = 1.0, unless h2d is less than IforcingDepthScale. fractionOfForcing = min(1.0, h2d(i,k)*IforcingDepthScale) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5117f693c2..8a22e21f43 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -148,8 +148,8 @@ module MOM_diabatic_driver real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers !! near the bottom [Z2 T-1 ~> m2 s-1]. - real :: minimum_forcing_depth = 0.001 !< The smallest depth over which heat and freshwater - !! fluxes are applied [m]. + real :: minimum_forcing_depth !< The smallest depth over which heat and freshwater + !! fluxes are applied [H ~> m or kg m-2]. real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be !! evaporated in one time-step [nondim]. integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that @@ -1136,7 +1136,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -1165,13 +1165,13 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) endif ! (CS%mix_boundary_tracers) call cpu_clock_end(id_clock_tracers) @@ -1810,7 +1810,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -1834,13 +1834,13 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug,& evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) else ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth) endif ! (CS%mix_boundary_tracers) call cpu_clock_end(id_clock_tracers) @@ -2869,7 +2869,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & real, optional, intent( out) :: evap_CFL_limit ! m or kg m-2]. type(diabatic_aux_CS), optional, pointer :: diabatic_aux_CSp !< A pointer to be set to the diabatic_aux !! control structure @@ -3349,7 +3349,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "only takes effect when near-surface layers become thin "//& "relative to this scale, in which case the forcing tendencies "//& "scaled down by distributing the forcing over this depth scale.", & - units="m", default=0.001) + units="m", default=0.001, scale=GV%m_to_H) call get_param(param_file, mdl, "EVAP_CFL_LIMIT", CS%evap_CFL_limit, & "The largest fraction of a layer than can be lost to forcing "//& "(e.g. evaporation, sea-ice formation) in one time-step. The unused "//& diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 9d9ec0ae73..f8bc58c8d8 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -171,7 +171,6 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & real, pointer :: tr_ptr(:,:,:) => NULL() real :: PI ! 3.1415926... calculated as 4*atan(1) real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: e(SZK_(G)+1), e_top, e_bot ! Heights [Z ~> m]. @@ -308,7 +307,7 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index f41fd09dde..aa23255759 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -273,7 +273,7 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 0686fe0c1e..3aa250b8bb 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -431,7 +431,7 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! CFCs are relatively simple, as they are passive tracers. with only a surface diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 1d860a5521..3cd81de052 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -410,7 +410,8 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, real, optional, intent(in) :: evap_CFL_limit !< Limits how much water can be fluxed out of !! the top layer Stored previously in diabatic CS. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied Stored previously in diabatic CS. + !! can be applied [H ~> m or kg m-2] + ! Stored previously in diabatic CS. ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index ec18618648..7da25d6841 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -118,8 +118,12 @@ module MOM_offline_main integer :: off_ale_mod !< Sets how frequently the ALE step is done during the advection real :: dt_offline !< Timestep used for offline tracers [T ~> s] real :: dt_offline_vertical !< Timestep used for calls to tracer vertical physics [T ~> s] - real :: evap_CFL_limit !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes - real :: minimum_forcing_depth !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes + real :: evap_CFL_limit !< Limit on the fraction of the water that can be fluxed out of the top + !! layer in a timestep [nondim]. This is Copied from diabatic_CS controlling + !! how tracers follow freshwater fluxes + real :: minimum_forcing_depth !< The smallest depth over which fluxes can be applied [H ~> m or kg m-2]. + !! This is copied from diabatic_CS controlling how tracers follow freshwater fluxes + real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity real :: min_residual !< The minimum amount of total mass flux before exiting the main advection routine !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport @@ -242,7 +246,9 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y - real :: evap_CFL_limit, minimum_forcing_depth + real :: evap_CFL_limit ! Limit on the fraction of the water that can be fluxed out of the + ! top layer in a timestep [nondim] + real :: minimum_forcing_depth ! The smallest depth over which fluxes can be applied [H ~> m or kg m-2] real :: dt_iter ! The timestep to use for each iteration [T ~> s] integer :: nstocks diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index e6319cb11e..ec7c025db0 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -238,7 +238,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim !! water that can be fluxed out of the top !! layer in a timestep [nondim] real, intent(in ) :: minimum_forcing_depth !< The smallest depth over - !! which fluxes can be applied [m] + !! which fluxes can be applied [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional !< The total time-integrated !! amount of tracer that enters with freshwater real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional !< The total time-integrated @@ -366,7 +366,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute ! forcing into deeper layers. - IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth*GV%m_to_H - netMassOut(i) ) + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) ! fractionOfForcing = 1.0, unless h2d is less than IforcingDepthScale. fractionOfForcing = min(1.0, h2d(i,k)*IforcingDepthScale) diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index d714c7f15d..f25c7f533d 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -300,7 +300,7 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can be !! fluxed out of the top layer in a timestep [nondim]. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied [m]. + !! can be applied [H ~> m or kg m-2]. ! The arguments to this subroutine are redundant in that ! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 85d63f155e..84bd44ed62 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -283,7 +283,7 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 411bd12696..e70320a5c7 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -232,7 +232,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index efa9a74e74..86a4ac7aeb 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -268,7 +268,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 2487b38d5c..198ee1bc4f 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -225,7 +225,7 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 9ea25b0da2..3ef61e1a57 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -306,7 +306,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 965fb44450..4d755497c6 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -322,7 +322,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index a945f6462b..5c74487c0c 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -198,7 +198,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which - !! fluxes can be applied [m] + !! fluxes can be applied [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. From c741390c424920baec8e171e0b2ed300aa3f02c4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Nov 2019 16:38:48 -0500 Subject: [PATCH 232/259] Correction of documented units in comments Corrected some units in comments and eliminated some unused variables. All answers are bitwise identical. --- src/core/MOM_variables.F90 | 6 ++--- src/diagnostics/MOM_PointAccel.F90 | 8 +++--- src/diagnostics/MOM_diagnostics.F90 | 6 ++--- src/parameterizations/lateral/MOM_MEKE.F90 | 12 ++++----- .../lateral/MOM_hor_visc.F90 | 20 +++++++------- .../lateral/MOM_internal_tides.F90 | 14 +++++----- .../lateral/MOM_lateral_mixing_coeffs.F90 | 26 +++++++------------ .../lateral/MOM_thickness_diffuse.F90 | 12 ++++----- .../vertical/MOM_diabatic_aux.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 6 ++--- .../vertical/MOM_energetic_PBL.F90 | 2 +- src/tracer/ISOMIP_tracer.F90 | 3 --- src/tracer/MOM_tracer_advect.F90 | 2 +- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/tracer/RGC_tracer.F90 | 5 +--- src/tracer/advection_test_tracer.F90 | 3 --- 16 files changed, 57 insertions(+), 72 deletions(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 586419f19e..5dfa91fee2 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -164,10 +164,10 @@ module MOM_variables dv_dt_dia => NULL() !< Meridional acceleration due to diapycnal mixing [L T-2 ~> m s-2] real, pointer, dimension(:,:,:) :: du_other => NULL() !< Zonal velocity changes due to any other processes that are - !! not due to any explicit accelerations [m s-1]. + !! not due to any explicit accelerations [L T-1 ~> m s-1]. real, pointer, dimension(:,:,:) :: dv_other => NULL() - !< Meridional velocity changes due to any other processes that are - !! not due to any explicit accelerations [m s-1]. + !< Meridional velocity changes due to any other processes that are + !! not due to any explicit accelerations [L T-1 ~> m s-1]. ! These accelerations are sub-terms included in the accelerations above. real, pointer :: gradKEu(:,:,:) => NULL() !< gradKEu = - d/dx(u2) [L T-2 ~> m s-2] diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index 276ba4e46e..4ad1b67314 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -216,7 +216,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%du_other)) then write(file,'(/,"du_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (ADp%du_other(I,j,k)); enddo + (US%L_T_to_m_s*ADp%du_other(I,j,k)); enddo endif if (present(a)) then write(file,'(/,"a: ",$)') @@ -379,7 +379,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%du_other)) then write(file,'(/,"du_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & - (ADp%du_other(I,j,k))*Inorm(k); enddo + (US%L_T_to_m_s*ADp%du_other(I,j,k))*Inorm(k); enddo endif if (associated(CS%u_accel_bt)) then write(file,'(/,"dubt: ",$)') @@ -553,7 +553,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%dv_other)) then write(file,'(/,"dv_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (ADp%dv_other(i,J,k)); enddo + (US%L_T_to_m_s*ADp%dv_other(i,J,k)); enddo endif if (present(a)) then write(file,'(/,"a: ",$)') @@ -711,7 +711,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt_in_T, G, GV, US, CS, vel_rp if (associated(ADp%dv_other)) then write(file,'(/,"dv_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & - (ADp%dv_other(i,J,k)*Inorm(k)); enddo + (US%L_T_to_m_s*ADp%dv_other(i,J,k)*Inorm(k)); enddo endif if (associated(CS%v_accel_bt)) then write(file,'(/,"dvbt: ",$)') diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ef55e456ac..5866fb1f39 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -693,8 +693,8 @@ end subroutine calculate_diagnostic_fields !! weights that should be assigned to elements k and k+1. subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) real, dimension(:), & - intent(in) :: Rlist !< The list of target densities [kg m-3] - real, intent(in) :: R_in !< The density being inserted into Rlist [kg m-3] + intent(in) :: Rlist !< The list of target densities [R ~> kg m-3] + real, intent(in) :: R_in !< The density being inserted into Rlist [R ~> kg m-3] integer, intent(inout) :: k !< The value of k such that Rlist(k) <= R_in < Rlist(k+1) !! The input value is a first guess integer, intent(in) :: nz !< The number of layers in Rlist @@ -1359,7 +1359,7 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy ! [H s-1 ~> m s-1 or kg m-2 s-1]. real :: Idt ! The inverse of the time interval [T-1 ~> s-1] real :: H_to_kg_m2_dt ! A conversion factor from accumulated transports to fluxes - ! [kg L-2 H-1 s-1 ~> kg m-3 s-1 or s-1]. + ! [kg L-2 H-1 T-1 ~> kg m-3 s-1 or s-1]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 55a9a71304..9513937c9d 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -358,20 +358,20 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculate Laplacian of MEKE !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-2,ie+1 - ! Here the units of MEKE_uflux are [L2 T-2]. + ! Here the units of MEKE_uflux are [L2 T-2 ~> m2 s-2]. MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%mask2dCu(I,j)) * & (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) - ! This would have units of [R Z L2 T-2] + ! This would have units of [R Z L2 T-2 ~> kg s-2] ! MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & ! ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & ! (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) enddo ; enddo !$OMP parallel do default(shared) do J=js-2,je+1 ; do i=is-1,ie+1 - ! Here the units of MEKE_vflux are [L2 T-2]. + ! Here the units of MEKE_vflux are [L2 T-2 ~> m2 s-2]. MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%mask2dCv(i,J)) * & (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) - ! This would have units of [R Z L2 T-2] + ! This would have units of [R Z L2 T-2 ~> kg s-2] ! MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * & ! ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & ! (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) @@ -436,7 +436,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max Kh_u(I,j) = Kh_here - ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3]. + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. MEKE_uflux(I,j) = ((Kh_here * (G%dy_Cu(I,j)*G%IdxCu(I,j))) * & ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & (MEKE%MEKE(i,j) - MEKE%MEKE(i+1,j)) @@ -451,7 +451,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (Kh_here*Inv_Kh_max > 0.25) Kh_here = 0.25 / Inv_Kh_max Kh_v(i,J) = Kh_here - ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3]. + ! Here the units of MEKE_uflux and MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. MEKE_vflux(i,J) = ((Kh_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & (MEKE%MEKE(i,j) - MEKE%MEKE(i,j+1)) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 3c5b25d12d..63811e14d7 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -85,9 +85,9 @@ module MOM_hor_visc !! answers from the end of 2018. Otherwise, use updated and more robust !! forms of the same expressions. real :: GME_h0 !< The strength of GME tapers quadratically to zero when the bathymetric - !! depth is shallower than GME_H0 [m] + !! depth is shallower than GME_H0 [Z ~> m] real :: GME_efficiency !< The nondimensional prefactor multiplying the GME coefficient [nondim] - real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [m2 s-1]. + real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [L2 T-1 ~> m2 s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. @@ -101,9 +101,9 @@ module MOM_hor_visc !< The background biharmonic viscosity at h points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Biharm5_const2_xx +! real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Biharm5_const2_xx !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [m4 s]. This value is + !! square of the velocity shear [L4 T ~> m4 s]. This value is !! set to be the magnitude of the Coriolis terms once the !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx @@ -123,9 +123,9 @@ module MOM_hor_visc !< The background biharmonic viscosity at q points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Biharm5_const2_xy +! real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Biharm5_const2_xy !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [m4 s]. This value is + !! square of the velocity shear [L4 T ~> m4 s]. This value is !! set to be the magnitude of the Coriolis terms once the !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy @@ -1234,7 +1234,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Make a similar calculation as for FrictWork above but accumulating into ! the vertically integrated MEKE source term, and adjusting for any - ! energy loss seen as a reduction in the [biharmonic] frictional source term. + ! energy loss seen as a reduction in the (biharmonic) frictional source term. if (find_FrictWork .and. associated(MEKE)) then ; if (associated(MEKE%mom_src)) then if (k==1) then do j=js,je ; do i=is,ie @@ -2239,9 +2239,9 @@ subroutine hor_visc_end(CS) endif if (CS%Smagorinsky_Ah) then DEALLOC_(CS%Biharm5_const_xx) ; DEALLOC_(CS%Biharm5_const_xy) - if (CS%bound_Coriolis) then - DEALLOC_(CS%Biharm5_const2_xx) ; DEALLOC_(CS%Biharm5_const2_xy) - endif + ! if (CS%bound_Coriolis) then + ! DEALLOC_(CS%Biharm5_const2_xx) ; DEALLOC_(CS%Biharm5_const2_xy) + ! endif endif if (CS%Leith_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index d6616a5ee0..d9e77f2180 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -175,7 +175,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & test real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] - Ub, & ! near-bottom horizontal velocity of wave (modal) [m s-1] + Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & flux_heat_y, & @@ -191,7 +191,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real :: I_D_here ! The inverse of the local depth [Z-1 ~> m-1] real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] real :: freq2 ! The frequency squared [T-2 ~> s-2] - real :: c_phase ! The phase speed [m s-1] + real :: c_phase ! The phase speed [L T-1 ~> m s-1] real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] @@ -772,8 +772,8 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. real :: favg ! The average Coriolis parameter at a point [T-1 ~> s-1]. real :: df_dy, df_dx ! The x- and y- gradients of the Coriolis parameter [T-1 L-1 ~> s-1 m-1]. - real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [m-1]. - real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [m-1]. + real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [L-1 ~> m-1]. + real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [L-1 ~> m-1]. real :: Angle_size, dt_Angle_size, angle real :: Ifreq, Kmag2, I_Kmag real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] @@ -980,7 +980,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) cos_angle, sin_angle real, dimension(NAngle) :: & Cgx_av, Cgy_av, dCgx, dCgy - real :: f2 ! The squared Coriolis parameter [s-2]. + real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. real :: Angle_size, I_Angle_size, angle real :: Ifreq ! The inverse of the frequency [T ~> s] real :: freq2 ! The frequency squared [T-2 ~> s-2] @@ -1367,7 +1367,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_x ! The internal wave energy flux [J s-1]. + flux_x ! The internal wave energy flux [J T-1 ~> J s-1]. real, dimension(SZIB_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p @@ -1442,7 +1442,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - flux_y ! The internal wave energy flux [J s-1]. + flux_y ! The internal wave energy flux [J T-1 ~> J s-1]. real, dimension(SZI_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 9e8dba4560..710012c837 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -708,8 +708,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type -! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [m s-1] -! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [m s-1] +! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [L T-1 ~> m s-1] +! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence @@ -721,21 +721,16 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity !! (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] ! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Kh_h !< Leith Laplacian viscosity - !! at h-points [m2 s-1] + !! at h-points [L2 T-1 ~> m2 s-1] ! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Kh_q !< Leith Laplacian viscosity - !! at q-points [m2 s-1] + !! at q-points [L2 T-1 ~> m2 s-1] ! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Ah_h !< Leith bi-harmonic viscosity - !! at h-points [m4 s-1] + !! at h-points [L4 T-1 ~> m4 s-1] ! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Ah_q !< Leith bi-harmonic viscosity - !! at q-points [m4 s-1] + !! at q-points [L4 T-1 ~> m4 s-1] ! Local variables -! real, dimension(SZIB_(G),SZJB_(G)) :: vort_xy, & ! Vertical vorticity (dv/dx - du/dy) [s-1] -! dudy, & ! Meridional shear of zonal velocity [s-1] -! dvdx ! Zonal shear of meridional velocity [s-1] real, dimension(SZI_(G),SZJB_(G)) :: & -! vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] -! div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] dslopey_dz, & ! z-derivative of y-slope at v-points [Z-1 ~> m-1] h_at_v, & ! Thickness at v-points [H ~> m or kg m-2] beta_v, & ! Beta at v-points [T-1 L-1 ~> s-1 m-1] @@ -743,16 +738,14 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo grad_div_mag_v ! Magnitude of divergence gradient at v-points [T-1 L-1 ~> s-1 m-1] real, dimension(SZIB_(G),SZJ_(G)) :: & -! vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] -! div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] dslopex_dz, & ! z-derivative of x-slope at u-points [Z-1 ~> m-1] h_at_u, & ! Thickness at u-points [H ~> m or kg m-2] beta_u, & ! Beta at u-points [T-1 L-1 ~> s-1 m-1] grad_vort_mag_u, & ! Magnitude of vorticity gradient at u-points [T-1 L-1 ~> s-1 m-1] grad_div_mag_u ! Magnitude of divergence gradient at u-points [T-1 L-1 ~> s-1 m-1] -! real, dimension(SZI_(G),SZJ_(G)) :: div_xx ! Estimate of horizontal divergence at h-points [s-1] -! real :: mod_Leith, DY_dxBu, DX_dyBu, vert_vort_mag - real :: h_at_slope_above, h_at_slope_below, Ih + real :: h_at_slope_above ! The thickness above [H ~> m or kg m-2] + real :: h_at_slope_below ! The thickness below [H ~> m or kg m-2] + real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz real :: inv_PI3 @@ -1052,6 +1045,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', 's-2') CS%id_N2_v = register_diag_field('ocean_model', 'N2_v', diag%axesCvi, Time, & 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', 's-2') + !### The units of the next two diagnostics should be 'nondim'. CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 's-2') CS%id_S2_v = register_diag_field('ocean_model', 'S2_v', diag%axesCv1, Time, & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ddaf61e397..a567edb4be 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -50,7 +50,7 @@ module MOM_thickness_diffuse real :: FGNV_scale !< A coefficient scaling the vertical smoothing term in the !! Ferrari et al., 2010, streamfunction formulation [nondim]. real :: FGNV_c_min !< A minimum wave speed used in the Ferrari et al., 2010, - !! streamfunction formulation [m s-1]. + !! streamfunction formulation [L T-1 ~> m s-1]. real :: N2_floor !< A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, !! streamfunction formulation [T-2 ~> s-2]. logical :: detangle_interfaces !< If true, add 3-d structured interface height @@ -831,7 +831,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_x_PE(I,j,k) = hN2_u(I,K) if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - ! Estimate the streamfunction at each interface [m3 s-1]. + ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*US%L_to_Z*Slope) ! Avoid moving dense water upslope from below the level of @@ -1081,7 +1081,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_y_PE(i,J,k) = hN2_v(i,K) if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - ! Estimate the streamfunction at each interface [m3 s-1]. + ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*US%L_to_Z*Slope) ! Avoid moving dense water upslope from below the level of @@ -1299,8 +1299,8 @@ end subroutine thickness_diffuse_full !> Tridiagonal solver for streamfunction at interfaces subroutine streamfn_solver(nk, c2_h, hN2, sfn) integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [m s-2] - real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [m s-2] + real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [L2 Z-1 T-2 ~> m s-2] + real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [L2 Z-1 T-2 ~> m s-2] real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [Z L2 T-1 ~> m3 s-1] or arbitrary units !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. @@ -1830,7 +1830,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "FGNV_C_MIN", CS%FGNV_c_min, & "A minium wave speed used in the Ferrari et al., 2010, "//& "streamfunction formulation.", & - default=0., units="m s-1", do_not_log=.not.CS%use_FGNV_streamfn) + default=0., units="m s-1", scale=US%m_s_to_L_T, do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_STRAT_FLOOR", strat_floor, & "A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, "//& "streamfunction formulation, expressed as a fraction of planetary "//& diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 853b6f57c2..fe1ae86ee6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -915,7 +915,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t T2d, & ! A 2-d copy of the layer temperatures [degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within ! a layer [R Z3 T-2 ~> J m-2] - dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 degC-1] + dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] real, dimension(SZI_(G)) :: & netPen_rate ! The surface penetrative shortwave heating rate summed over all bands ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 8a22e21f43..f65a0e8eae 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -535,7 +535,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] - real :: Idt ! The inverse time step [s-1] + real :: Idt ! The inverse time step [T-1 ~> s-1] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree @@ -1318,7 +1318,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] - real :: Idt ! The inverse time step [s-1] + real :: Idt ! The inverse time step [T-1 ~> s-1] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree @@ -2007,7 +2007,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] real :: dt_mix ! The amount of time over which to apply mixing [T ~> s] - real :: Idt ! The inverse time step [s-1] + real :: Idt ! The inverse time step [T-1 ~> s-1] real :: Idt_accel ! The inverse time step times rescaling factors [T-1 ~> s-1] integer :: dir_flag ! An integer encoding the directions in which to do halo updates. diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 8ae83ca615..f8c20682ee 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -554,7 +554,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] - real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1]. + real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: u_star_mean !< The surface friction velocity without any !! contribution from unresolved gustiness [Z T-1 ~> m s-1]. diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index aa23255759..c2b189917c 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -177,9 +177,6 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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 :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: e(SZK_(G)+1), e_top, e_bot, d_tr diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 77d28e6767..e050933dc2 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -28,7 +28,7 @@ module MOM_tracer_advect !> Control structure for this module type, public :: tracer_advect_CS ; private - real :: dt !< The baroclinic dynamics time step [s]. + real :: dt !< The baroclinic dynamics time step [T ~> s]. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !< timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 3dd89881b2..2d42483c49 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -139,7 +139,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online Kh_u ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & khdt_y, & ! The value of Khtr*dt times the open face width divided by - ! the distance between adjacent tracer points [L2]. + ! the distance between adjacent tracer points [L2 ~> m2]. Coef_y, & ! The coefficients relating meridional tracer differences ! to time-integrated fluxes [H L2 ~> m3 or kg]. Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index f25c7f533d..028718f379 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -183,11 +183,8 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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 :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line, in m2. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg-2]. real :: e(SZK_(G)+1), e_top, e_bot, d_tr ! Heights [Z ~> m]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 84bd44ed62..e81003c0ff 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -194,9 +194,6 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS 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 :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m From f8f106af931c9689294883097a1a34d63f36e541 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 19 Nov 2019 13:05:29 -0500 Subject: [PATCH 233/259] Adiabatic clock ID bugfix This patch fixes an initialization bug of the diabatic timer, which was being used to measure adiabatic time but was never initialized if the experiment was configured as adiabatic. We fix this by introducing a separate timer for the adiabatic solver. Although we could have reused the diabatic timer, the addition of a new variable should not add any overhead on modern compilers. --- src/core/MOM.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a29a555f55..aea2ff479b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -370,6 +370,7 @@ module MOM integer :: id_clock_thermo integer :: id_clock_tracer integer :: id_clock_diabatic +integer :: id_clock_adiabatic integer :: id_clock_continuity ! also in dynamics s/r integer :: id_clock_thick_diff integer :: id_clock_BBL_visc @@ -1275,10 +1276,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_end(id_clock_diabatic) else ! complement of "if (.not.CS%adiabatic)" - call cpu_clock_begin(id_clock_diabatic) + call cpu_clock_begin(id_clock_adiabatic) call adiabatic(h, tv, fluxes, US%T_to_s*dtdia, G, GV, CS%diabatic_CSp) fluxes%fluxes_used = .true. - call cpu_clock_end(id_clock_diabatic) + call cpu_clock_end(id_clock_adiabatic) if (associated(tv%T)) then call create_group_pass(pass_T_S, tv%T, G%Domain, To_All+Omit_Corners, halo=1) @@ -2566,8 +2567,11 @@ subroutine MOM_timing_init(CS) id_clock_thermo = cpu_clock_id('Ocean thermodynamics and tracers', grain=CLOCK_SUBCOMPONENT) id_clock_other = cpu_clock_id('Ocean Other', grain=CLOCK_SUBCOMPONENT) id_clock_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER) - if (.not.CS%adiabatic) & + if (.not.CS%adiabatic) then id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER) + else + id_clock_adiabatic = cpu_clock_id('(Ocean adiabatic driver)', grain=CLOCK_MODULE_DRIVER) + endif id_clock_continuity = cpu_clock_id('(Ocean continuity equation *)', grain=CLOCK_MODULE) id_clock_BBL_visc = cpu_clock_id('(Ocean set BBL viscosity)', grain=CLOCK_MODULE) From 2ae0a680bdd0ff38156af4b84f78d273140acd03 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 20 Nov 2019 15:38:11 -0500 Subject: [PATCH 234/259] Corrected an OMP declaration Added a variable to an OMP declaration. All answers are bitwise identical, and a recently added compile-time error with openMP was fixed. --- src/diagnostics/MOM_wave_speed.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index db65068c52..eb11a2b5e9 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -167,7 +167,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S,tv,& !$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & !$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2) & +!$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2,c2_scale) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & !$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & !$OMP drho_dS,drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& From 686302e75c9d29a0f75d612c3e656f3e58a7c018 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 22 Nov 2019 11:47:35 -0500 Subject: [PATCH 235/259] Update MOM.F90 Fixed Alistair's embarrassing error. --- 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 af05c578c2..7a06563c97 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1276,7 +1276,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_end(id_clock_diabatic) else ! complement of "if (.not.CS%adiabatic)" - call cpu_clock_begin(id_clock_diabatic) + call cpu_clock_begin(id_clock_adiabatic) call adiabatic(h, tv, fluxes, US%T_to_s*dtdia, G, GV, US, CS%diabatic_CSp) fluxes%fluxes_used = .true. call cpu_clock_end(id_clock_adiabatic) From aaa58cabc140eaa9bef42e8f8f92c51ead107267 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 25 Nov 2019 18:29:41 -0500 Subject: [PATCH 236/259] Dimensional rescaling in MOM_open_boundary.F90 Added rescaling for dimensional consistency testing in MOM_open_boundary.F90, including splitting variables with different units that had previously shared the same variable and adding more extensive documentation of variables. Also changed the dimensions of the timesteps passed to radiation_open_bdry_conds and update_segment_tracer_reservoirs to [T] and added vertical_grid_type and unit_scale_type arguments to open_boundary_init and open_boundary_test_extern_h. All answers are bitwise identical, although some probably bugs have been noted in comments and there are new or altered arguments to several routines. --- src/core/MOM.F90 | 4 +- src/core/MOM_dynamics_split_RK2.F90 | 8 +- src/core/MOM_open_boundary.F90 | 844 ++++++++++-------- .../MOM_state_initialization.F90 | 4 +- 4 files changed, 469 insertions(+), 391 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7a06563c97..ad9e235b27 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1092,7 +1092,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & - US%T_to_s*CS%t_dyn_rel_adv, CS%tracer_Reg) + CS%t_dyn_rel_adv, CS%tracer_Reg) 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) @@ -1277,7 +1277,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & else ! complement of "if (.not.CS%adiabatic)" call cpu_clock_begin(id_clock_adiabatic) - call adiabatic(h, tv, fluxes, US%T_to_s*dtdia, G, GV, US, CS%diabatic_CSp) + call adiabatic(h, tv, fluxes, dtdia, G, GV, US, CS%diabatic_CSp) fluxes%fluxes_used = .true. call cpu_clock_end(id_clock_adiabatic) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 957a3338ca..c479550847 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -363,7 +363,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then - if (CS%debug_OBC) call open_boundary_test_extern_h(G, CS%OBC, h) + if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) 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) @@ -611,7 +611,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, US, US%T_to_s*dt_pred) + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, US, dt_pred) if (CS%debug) & call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -819,7 +819,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then - call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, US, US%T_to_s*dt) + call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, US, dt) endif ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. @@ -1170,7 +1170,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param elseif ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IeDB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = vel_rescale * CS%v_av(i,J,k) ; enddo ; enddo ; enddo endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4a2b734e99..c6101f2f31 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -15,7 +15,7 @@ module MOM_open_boundary use MOM_io, only : EAST_FACE, NORTH_FACE use MOM_io, only : slasher, read_data, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup @@ -57,7 +57,7 @@ module MOM_open_boundary integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary -integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed sall +integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed wall integer, parameter, public :: OBC_FLATHER = 3 !< Indicates the use of a Flather open boundary integer, parameter, public :: OBC_RADIATION = 4 !< Indicates the use of a radiation open boundary integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary @@ -76,7 +76,7 @@ module MOM_open_boundary integer :: nk_src !< Number of vertical levels in the source data real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment data [m] real, dimension(:,:,:), pointer :: buffer_dst=>NULL() !< buffer src data remapped to the target vertical grid - real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [m s-1] + real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [L T-1 ~> m s-1] real :: value !< constant value if fid is equal to -1 end type OBC_segment_data_type @@ -138,12 +138,12 @@ module MOM_open_boundary integer :: Ie_obc !< i-indices of boundary segment. integer :: Js_obc !< j-indices of boundary segment. integer :: Je_obc !< j-indices of boundary segment. - real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [s]. - real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [s]. + real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [T ~> s]. + real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [T ~> s]. logical :: on_pe !< true if segment is located in the computational domain logical :: temp_segment_data_exists !< true if temperature data arrays are present logical :: salt_segment_data_exists !< true if salinity data arrays are present - real, pointer, dimension(:,:) :: Cg=>NULL() !< The external gravity wave speed [m s-1] + real, pointer, dimension(:,:) :: Cg=>NULL() !< The external gravity wave speed [L T-1 ~> m s-1] !! at OBC-points. real, pointer, dimension(:,:) :: Htot=>NULL() !< The total column thickness [H ~> m or kg m-2] at OBC-points. real, pointer, dimension(:,:,:) :: h=>NULL() !< The cell thickness [H ~> m or kg m-2] at OBC-points. @@ -159,17 +159,21 @@ module MOM_open_boundary !! the OB segment [L T-1 ~> m s-1]. real, pointer, dimension(:,:) :: eta=>NULL() !< The sea-surface elevation along the segment [m]. real, pointer, dimension(:,:,:) :: grad_normal=>NULL() !< The gradient of the normal flow along the - !! segment [T-1 ~> s-1] + !! segment times the grid spacing [L T-1 ~> m s-1] real, pointer, dimension(:,:,:) :: grad_tan=>NULL() !< The gradient of the tangential flow along the - !! segment [T-1 ~> s-1] - real, pointer, dimension(:,:,:) :: grad_gradient=>NULL() !< The gradient of the gradient of tangential flow along the - !! segment times a grid spacing [T-1 ~> s-1] - real, pointer, dimension(:,:,:) :: rx_normal=>NULL() !< The rx_old_u value for radiation coeff - !! for normal velocity - real, pointer, dimension(:,:,:) :: ry_normal=>NULL() !< The tangential value for radiation coeff - !! for normal velocity + !! segment times the grid spacing [L T-1 ~> m s-1] + real, pointer, dimension(:,:,:) :: grad_gradient=>NULL() !< The gradient of the gradient of tangential flow along + !! the segment times the grid spacing [T-1 ~> s-1] + real, pointer, dimension(:,:,:) :: rx_norm_rad=>NULL() !< The previous normal phase speed use for EW radiation + !! OBC, in grid points per timestep [nondim] + real, pointer, dimension(:,:,:) :: ry_norm_rad=>NULL() !< The previous normal phase speed use for NS radiation + !! OBC, in grid points per timestep [nondim] + real, pointer, dimension(:,:,:) :: rx_norm_obl=>NULL() !< The previous normal radiation coefficient for EW + !! oblique OBCs [L2 T-2 ~> m2 s-2] + real, pointer, dimension(:,:,:) :: ry_norm_obl=>NULL() !< The previous normal radiation coefficient for NS + !! oblique OBCs [L2 T-2 ~> m2 s-2] real, pointer, dimension(:,:,:) :: cff_normal=>NULL() !< The denominator for oblique radiation - !! for normal velocity + !! for normal velocity [L2 T-2 ~> m2 s-2] real, pointer, dimension(:,:,:) :: nudged_normal_vel=>NULL() !< The layer velocity normal to the OB segment !! that values should be nudged towards [L T-1 ~> m s-1]. real, pointer, dimension(:,:,:) :: nudged_tangential_vel=>NULL() !< The layer velocity tangential to the OB segment @@ -178,11 +182,13 @@ module MOM_open_boundary !! can occur [T-1 ~> s-1]. type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment. type(hor_index_type) :: HI !< Horizontal index ranges - real :: Tr_InvLscale_out !< An effective inverse length scale [m-1] - real :: Tr_InvLscale_in !< for restoring the tracer concentration in a - !! ficticious reservior towards interior values - !! when flow is exiting the domain, or towards - !! an externally imposed value when flow is entering + real :: Tr_InvLscale_out !< An effective inverse length scale for restoring + !! the tracer concentration in a ficticious + !! reservior towards interior values when flow + !! is exiting the domain [L-1 ~> m-1] + real :: Tr_InvLscale_in !< An effective inverse length scale for restoring + !! the tracer concentration towards an externally + !! imposed value when flow is entering [L-1 ~> m-1] end type OBC_segment_type !> Open-boundary data @@ -256,17 +262,21 @@ module MOM_open_boundary logical :: OBC_pe !< Is there an open boundary on this tile? type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries - real, pointer, dimension(:,:,:) :: rx_normal => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:) :: ry_normal => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:) :: cff_normal => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:,:) :: tres_x => NULL() !< Array storage for restarts - real, pointer, dimension(:,:,:,:) :: tres_y => NULL() !< Array storage for restarts - real :: silly_h !< A silly value of thickness outside of the domain that - !! can be used to test the independence of the OBCs to - !! this external data [H ~> m or kg m-2]. - real :: silly_u !< A silly value of velocity outside of the domain that - !! can be used to test the independence of the OBCs to - !! this external data [m s-1]. + real, pointer, dimension(:,:,:) :: & + rx_normal => NULL(), & !< Array storage for normal phase speed for EW radiation OBCs in units of + !! grid points per timestep [nondim] + ry_normal => NULL(), & !< Array storage for normal phase speed for NS radiation OBCs in units of + !! grid points per timestep [nondim] + rx_oblique => NULL(), & !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] + ry_oblique => NULL(), & !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] + cff_normal => NULL() !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] + real, pointer, dimension(:,:,:,:) :: & + tres_x => NULL(), & !< Array storage of tracer reservoirs for restarts [conc L ~> conc m] + tres_y => NULL() !< Array storage of tracer reservoirs for restarts [conc L ~> conc m] + real :: silly_h !< A silly value of thickness outside of the domain that can be used to test + !! the independence of the OBCs to this external data [H ~> m or kg m-2]. + real :: silly_u !< A silly value of velocity outside of the domain that can be used to test + !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -304,8 +314,8 @@ module MOM_open_boundary !> later call to update_open_boundary_data subroutine open_boundary_config(G, US, param_file, OBC) - type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables @@ -314,7 +324,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG - real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries + real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] allocate(OBC) call log_version(param_file, mdl, version, & @@ -399,11 +409,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& - "conditions for debugging.", units="m", default=0.0, & + "conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, & do_not_log=.not.debug_OBC, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & "A silly value of velocities used outside of open boundary "//& - "conditions for debugging.", units="m/s", default=0.0, & + "conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, & do_not_log=.not.debug_OBC, debuggingParam=.true.) reentrant_x = .false. call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) @@ -453,9 +463,9 @@ subroutine open_boundary_config(G, US, 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, param_file, reentrant_y) + call setup_u_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_y) elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, segment_str, l, param_file, reentrant_x) + call setup_v_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_x) else call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) @@ -477,7 +487,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) "time level (1) or the running mean (0) for velocities. "//& "Valid values range from 0 to 1. This is only used if "//& "one of the open boundary segments is using Orlanski.", & - units="nondim", default=0.3) + units="nondim", default=0.3) endif Lscale_in = 0. @@ -486,12 +496,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & "An effective length scale for restoring the tracer concentration "//& "at the boundaries to externally imposed values when the flow "//& - "is exiting the domain.", units="m", default=0.0) + "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L) call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & "An effective length scale for restoring the tracer concentration "//& "at the boundaries to values from the interior when the flow "//& - "is entering the domain.", units="m", default=0.0) + "is entering the domain.", units="m", default=0.0, scale=US%m_to_L) endif if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC) @@ -500,9 +510,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained ! by data while others are well constrained - MJH. do l = 1, OBC%number_of_segments - OBC%segment(l)%Tr_InvLscale_in=0.0 + OBC%segment(l)%Tr_InvLscale_in = 0.0 if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale_in = 1.0/Lscale_in - OBC%segment(l)%Tr_InvLscale_out=0.0 + OBC%segment(l)%Tr_InvLscale_out = 0.0 if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo @@ -758,8 +768,10 @@ subroutine initialize_segment_data(G, OBC, PF) segment%field(m)%name = trim(fields(m)) if (segment%field(m)%name == 'U') then segment%u_values_needed = .false. + !### segment%field(m)%value = US%m_s_to_L_T*segment%field(m)%value elseif (segment%field(m)%name == 'V') then segment%v_values_needed = .false. + !### segment%field(m)%value = US%m_s_to_L_T*segment%field(m)%value elseif (segment%field(m)%name == 'SSH') then segment%z_values_needed = .false. elseif (segment%field(m)%name == 'TEMP') then @@ -768,6 +780,7 @@ subroutine initialize_segment_data(G, OBC, PF) segment%s_values_needed = .false. elseif (segment%field(m)%name == 'DVDX' .or. segment%field(m)%name == 'DUDY') then segment%g_values_needed = .false. + !### segment%field(m)%value = US%T_to_s*segment%field(m)%value endif endif enddo @@ -844,9 +857,10 @@ 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, PF, reentrant_y) +subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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) :: PF !< Parameter file handle @@ -938,12 +952,12 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment, "//& - "for inflow, then outflow. Setting both to zero should "//& - "behave like SIMPLE obcs for the baroclinic velocities.", & - fail_if_missing=.true.,default=0.,units="days") - OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. - OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& + "behave like SIMPLE obcs for the baroclinic velocities.", & + fail_if_missing=.true., default=0., units="days", scale=86400.0*US%s_to_T) + OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1) + OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2) deallocate(tnudge) endif @@ -979,9 +993,10 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) 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, PF, reentrant_x) +subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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 !< Parameter file handle @@ -1074,12 +1089,12 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment, "//& - "for inflow, then outflow. Setting both to zero should "//& - "behave like SIMPLE obcs for the baroclinic velocities.", & - fail_if_missing=.true.,default=0.,units="days") - OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. - OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. + "Timescales in days for nudging along a segment, "//& + "for inflow, then outflow. Setting both to zero should "//& + "behave like SIMPLE obcs for the baroclinic velocities.", & + fail_if_missing=.true., default=0., units="days", scale=86400.0*US%s_to_T) + OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1) + OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2) deallocate(tnudge) endif @@ -1461,17 +1476,67 @@ subroutine parse_segment_param_real(segment_str, var, param_value, debug ) 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 - type(param_file_type), intent(in) :: param_file !< Parameter file handle - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure +!> Initialize open boundary control structure and do any necessary rescaling of OBC +!! fields that have been read from a restart file. +subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) + ! Local variables + real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in + ! a restart file to the internal representation in this run. + integer :: i, j, k, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (.not.associated(OBC)) return id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) + ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid + ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to + ! permit timesteps to change between calls to the OBC code, the following would be needed: +! if ( OBC%radiation_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & +! ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then +! vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) +! if (query_initialized(OBC%rx_normal, "rx_normal", restart_CSp)) then +! do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB +! OBC%rx_normal(I,j,k) = vel_rescale * OBC%rx_normal(I,j,k) +! enddo ; enddo ; enddo +! endif +! if (query_initialized(OBC%ry_normal, "ry_normal", restart_CSp)) then +! do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied +! OBC%ry_normal(i,J,k) = vel_rescale * OBC%ry_normal(i,J,k) +! enddo ; enddo ; enddo +! endif +! endif + + ! The oblique boundary condition terms have units of [L2 T-2 ~> m2 s-2] and may need to be rescaled. + if ( OBC%oblique_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & + ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then + vel2_rescale = (US%m_to_L * US%s_to_T_restart)**2 / (US%m_to_L_restart * US%s_to_T)**2 + if (query_initialized(OBC%rx_oblique, "rx_oblique", restart_CSp)) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + OBC%rx_oblique(I,j,k) = vel2_rescale * OBC%rx_oblique(I,j,k) + enddo ; enddo ; enddo + endif + if (query_initialized(OBC%ry_oblique, "ry_oblique", restart_CSp)) then + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + OBC%ry_oblique(i,J,k) = vel2_rescale * OBC%ry_oblique(i,J,k) + enddo ; enddo ; enddo + endif + if (query_initialized(OBC%cff_normal, "cff_normal", restart_CSp)) then + do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB + OBC%cff_normal(I,J,k) = vel2_rescale * OBC%cff_normal(I,J,k) + enddo ; enddo ; enddo + endif + endif + end subroutine open_boundary_init logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, & @@ -1513,6 +1578,8 @@ subroutine open_boundary_dealloc(OBC) if (associated(OBC%segnum_v)) deallocate(OBC%segnum_v) if (associated(OBC%rx_normal)) deallocate(OBC%rx_normal) if (associated(OBC%ry_normal)) deallocate(OBC%ry_normal) + if (associated(OBC%rx_oblique)) deallocate(OBC%rx_oblique) + if (associated(OBC%ry_oblique)) deallocate(OBC%ry_oblique) if (associated(OBC%cff_normal)) deallocate(OBC%cff_normal) if (associated(OBC%tres_x)) deallocate(OBC%tres_x) if (associated(OBC%tres_y)) deallocate(OBC%tres_y) @@ -1732,19 +1799,24 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) !! barotropic accelerations [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v_old !< Original unadjusted v [L T-1 ~> m s-1] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: dt !< Appropriate timestep [s] + real, intent(in) :: dt !< Appropriate timestep [T ~> s] ! Local variables real :: dhdt, dhdx, dhdy ! One-point differences in time or space [L T-1 ~> m s-1] - real :: gamma_u, gamma_v, gamma_2 - real :: cff, Cx, Cy, tau - real :: rx_max, ry_max ! coefficients for radiation - real :: rx_new, rx_avg ! coefficients for radiation - real :: ry_new, ry_avg ! coefficients for radiation - real :: cff_new, cff_avg ! denominator in oblique - real, pointer, dimension(:,:,:) :: rx_tangential=>NULL() - real, pointer, dimension(:,:,:) :: ry_tangential=>NULL() - real, pointer, dimension(:,:,:) :: cff_tangential=>NULL() - real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2]? + real :: gamma_u, gamma_2 ! Fractional weightings of new values [nondim] + real :: tau ! A local nudging timescale [T ~> s] + real :: rx_max, ry_max ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: rx_new, rx_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: ry_new, ry_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: cff_new, cff_avg ! denominator in oblique [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: & + rx_tang_rad, & ! The phase speed at u-points for tangential oblique OBCs + ! in units of grid points per timestep [nondim] + ry_tang_rad, & ! The phase speed at v-points for tangential oblique OBCs + ! in units of grid points per timestep [nondim] + rx_tang_obl, & ! The x-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2] + ry_tang_obl, & ! The y-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2] + cff_tangential ! The denominator for tangential oblique OBCs [L2 T-2 ~> m2 s-2] + real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2] type(OBC_segment_type), pointer :: segment => NULL() integer :: i, j, k, is, ie, js, je, m, nz, n integer :: is_obc, ie_obc, js_obc, je_obc @@ -1769,14 +1841,14 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) do k=1,G%ke I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) + segment%rx_norm_rad(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%JsdB do i=segment%HI%isd,segment%HI%ied - segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%ry_norm_rad(i,J,k) = OBC%ry_normal(i,J,k) enddo enddo endif @@ -1784,8 +1856,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) do k=1,G%ke I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) - segment%ry_normal(I,j,k) = OBC%ry_normal(I,j,k) + segment%rx_norm_obl(I,j,k) = OBC%rx_oblique(I,j,k) + segment%ry_norm_obl(I,j,k) = OBC%ry_oblique(I,j,k) segment%cff_normal(I,j,k) = OBC%cff_normal(I,j,k) enddo enddo @@ -1793,8 +1865,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) do k=1,G%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%rx_normal(i,J,k) = OBC%rx_normal(i,J,k) - segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%rx_norm_obl(i,J,k) = OBC%rx_oblique(i,J,k) + segment%ry_norm_obl(i,J,k) = OBC%ry_oblique(i,J,k) segment%cff_normal(i,J,k) = OBC%cff_normal(i,J,k) enddo enddo @@ -1832,7 +1904,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif enddo - gamma_u = OBC%gamma_uv ; gamma_v = OBC%gamma_uv + gamma_u = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments segment=>OBC%segment(n) @@ -1848,11 +1920,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) ! outward phase speed if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new else rx_avg = rx_new endif - segment%rx_normal(I,j,k) = rx_avg + segment%rx_norm_rad(I,j,k) = rx_avg ! The new boundary value is interpolated between future interior ! value, u_new(I-1) and past boundary value but with barotropic ! accelerations, u_new(I). @@ -1860,7 +1932,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability if (gamma_u < 1.0) then - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) endif elseif (segment%oblique) then dhdt = (u_old(I-1,j,k) - u_new(I-1,j,k)) !old-new @@ -1873,20 +1945,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_normal(J,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & @@ -1895,8 +1967,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary ! implementation as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) endif elseif (segment%gradient) then @@ -1910,45 +1982,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) enddo else do J=segment%HI%JsdB,segment%HI%JedB dhdt = v_old(i,J,k)-v_new(i,J,k) !old-new dhdx = v_new(i,J,k)-v_new(i-1,J,k) !in new time backward sasha for I-1 - rx_tangential(I,J,k) = 0.0 - if (dhdt*dhdx > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) / (1.0+rx_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -1956,13 +2028,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=Js_obc,Je_obc - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) ! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * US%s_to_T*dt * G%IdxBu(I-1,J) +! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k)) * dt * G%IdxBu(I-1,J) ! elseif (G%mask2dCu(I-1,j) > 0.0) then -! rx_avg = u_new(I-1,j,k) * US%s_to_T*dt * G%IdxBu(I-1,J) +! rx_avg = u_new(I-1,j,k) * dt * G%IdxBu(I-1,J) ! elseif (G%mask2dCu(I-1,j+1) > 0.0) then -! rx_avg = u_new(I-1,j+1,k) * US%s_to_T*dt * G%IdxBu(I-1,J) +! rx_avg = u_new(I-1,j+1,k) * dt * G%IdxBu(I-1,J) ! else ! rx_avg = 0.0 ! endif @@ -1973,34 +2045,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) + deallocate(rx_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) - ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) enddo else @@ -2015,19 +2087,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) - & (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & @@ -2038,13 +2110,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2052,8 +2124,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & @@ -2066,18 +2138,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -2092,11 +2164,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = 0.0 if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_rad(I,j,k) + gamma_u*rx_new else rx_avg = rx_new endif - segment%rx_normal(I,j,k) = rx_avg + segment%rx_norm_rad(I,j,k) = rx_avg ! The new boundary value is interpolated between future interior ! value, u_new(I+1) and past boundary value but with barotropic ! accelerations, u_new(I). @@ -2104,7 +2176,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) endif elseif (segment%oblique) then dhdt = (u_old(I+1,j,k) - u_new(I+1,j,k)) !old-new @@ -2118,20 +2190,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & @@ -2140,8 +2212,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) endif elseif (segment%gradient) then @@ -2155,45 +2227,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & + segment%normal_vel(I,j,k) = (1.0 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + rx_tang_rad(I,segment%HI%JsdB,k) = segment%rx_norm_rad(I,segment%HI%jsd,k) + rx_tang_rad(I,segment%HI%JedB,k) = segment%rx_norm_rad(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + rx_tang_rad(I,J,k) = 0.5*(segment%rx_norm_rad(I,j,k) + segment%rx_norm_rad(I,j+1,k)) enddo else do J=segment%HI%JsdB,segment%HI%JedB dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I-1 - rx_tangential(I,J,k) = 0.0 - if (dhdt*dhdx > 0.0) rx_tangential(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed + rx_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdx > 0.0) rx_tang_rad(I,J,k) = min( (dhdt/dhdx), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) / (1.0+rx_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2201,13 +2273,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=Js_obc,Je_obc - rx_avg = rx_tangential(I,J,k) + rx_avg = rx_tang_rad(I,J,k) ! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * US%s_to_T*dt * G%IdxBu(I+1,J) +! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k)) * dt * G%IdxBu(I+1,J) ! elseif (G%mask2dCu(I+1,j) > 0.0) then -! rx_avg = u_new(I+1,j,k) * US%s_to_T*dt * G%IdxBu(I+1,J) +! rx_avg = u_new(I+1,j,k) * dt * G%IdxBu(I+1,J) ! elseif (G%mask2dCu(I+1,j+1) > 0.0) then -! rx_avg = u_new(I+1,j+1,k) * US%s_to_T*dt * G%IdxBu(I+1,J) +! rx_avg = u_new(I+1,j+1,k) * dt * G%IdxBu(I+1,J) ! else ! rx_avg = 0.0 ! endif @@ -2218,34 +2290,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) + deallocate(rx_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then I=segment%HI%IsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) - rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) - ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) - ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + rx_tang_obl(I,segment%HI%JsdB,k) = segment%rx_norm_obl(I,segment%HI%jsd,k) + rx_tang_obl(I,segment%HI%JedB,k) = segment%rx_norm_obl(I,segment%HI%jed,k) + ry_tang_obl(I,segment%HI%JsdB,k) = segment%ry_norm_obl(I,segment%HI%jsd,k) + ry_tang_obl(I,segment%HI%JedB,k) = segment%ry_norm_obl(I,segment%HI%jed,k) cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(I,j,k) + segment%rx_norm_obl(I,j+1,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(I,j,k) + segment%ry_norm_obl(I,j+1,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) enddo else @@ -2260,19 +2332,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = US%L_T_to_m_s**2*dhdt*dhdx - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdy,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) - & (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + & @@ -2283,13 +2355,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2297,8 +2369,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Js_obc = max(segment%HI%JsdB,G%jsd+1) Je_obc = min(segment%HI%JedB,G%jed-1) do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & @@ -2311,18 +2383,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (rx_tangential(I,J,k) <= 0.0) then + if (rx_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -2337,11 +2409,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) if (gamma_u < 1.0) then - ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new else ry_avg = ry_new endif - segment%ry_normal(i,J,k) = ry_avg + segment%ry_norm_rad(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J-1) and past boundary value but with barotropic ! accelerations, v_new(J). @@ -2349,7 +2421,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) endif elseif (segment%oblique) then dhdt = (v_old(i,J-1,k) - v_new(i,J-1,k)) !old-new @@ -2362,20 +2434,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_normal(I,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) +& @@ -2384,8 +2456,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) endif elseif (segment%gradient) then @@ -2399,45 +2471,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) enddo else do I=segment%HI%IsdB,segment%HI%IedB dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I-1 - ry_tangential(I,J,k) = 0.0 - if (dhdt*dhdy > 0.0) ry_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2445,13 +2517,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) ! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * US%s_to_T*dt * G%IdyBu(I,J-1)) +! ry_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k) * dt * G%IdyBu(I,J-1)) ! elseif (G%mask2dCv(i,J-1) > 0.0) then -! ry_avg = v_new(i,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) +! ry_avg = v_new(i,J-1,k) * dt *G%IdyBu(I,J-1) ! elseif (G%mask2dCv(i+1,J-1) > 0.0) then -! ry_avg = v_new(i+1,J-1,k) * US%s_to_T*dt *G%IdyBu(I,J-1) +! ry_avg = v_new(i+1,J-1,k) * dt *G%IdyBu(I,J-1) ! else ! ry_avg = 0.0 ! endif @@ -2462,34 +2534,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(ry_tangential) + deallocate(ry_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then J=segment%HI%JsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) enddo else @@ -2504,19 +2576,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + ry_avg*u_new(I,j-1,k)) - & (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & @@ -2527,13 +2599,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2541,8 +2613,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & @@ -2555,18 +2627,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -2581,11 +2653,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) if (gamma_u < 1.0) then - ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_rad(I,j,k) + gamma_u*ry_new else ry_avg = ry_new endif - segment%ry_normal(i,J,k) = ry_avg + segment%ry_norm_rad(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J+1) and past boundary value but with barotropic ! accelerations, v_new(J). @@ -2593,7 +2665,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) endif elseif (segment%oblique) then dhdt = (v_old(i,J+1,k) - v_new(i,J+1,k)) !old-new @@ -2607,20 +2679,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif - segment%rx_normal(I,j,k) = rx_avg - segment%ry_normal(i,J,k) = ry_avg + segment%rx_norm_obl(I,j,k) = rx_avg + segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + & @@ -2629,8 +2701,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) - OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) endif elseif (segment%gradient) then @@ -2644,45 +2716,45 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & + segment%normal_vel(i,J,k) = (1.0 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo ; enddo if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_rad(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tang_rad(segment%HI%IsdB,J,k) = segment%ry_norm_rad(segment%HI%isd,J,k) + ry_tang_rad(segment%HI%IedB,J,k) = segment%ry_norm_rad(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tang_rad(I,J,k) = 0.5*(segment%ry_norm_rad(i,J,k) + segment%ry_norm_rad(i+1,J,k)) enddo else do I=segment%HI%IsdB,segment%HI%IedB dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I-1 - ry_tangential(I,J,k) = 0.0 - if (dhdt*dhdy > 0.0) ry_tangential(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed + ry_tang_rad(I,J,k) = 0.0 + if (dhdt*dhdy > 0.0) ry_tang_rad(I,J,k) = min( (dhdt/dhdy), rx_max) ! outward phase speed enddo endif enddo if (segment%radiation_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) / (1.0+ry_avg) enddo ; enddo endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2690,13 +2762,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=Is_obc,Ie_obc - ry_avg = ry_tangential(I,J,k) + ry_avg = ry_tang_rad(I,J,k) ! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k)) * dt * G%IdyBu(I,J+1) ! elseif (G%mask2dCv(i,J+1) > 0.0) then -! ry_avg = v_new(i,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = v_new(i,J+1,k) * dt * G%IdyBu(I,J+1) ! elseif (G%mask2dCv(i+1,J+1) > 0.0) then -! ry_avg = v_new(i+1,J+1,k) * US%s_to_T*dt * G%IdyBu(I,J+1) +! ry_avg = v_new(i+1,J+1,k) * dt * G%IdyBu(I,J+1) ! else ! ry_avg = 0.0 ! endif @@ -2707,34 +2779,34 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(ry_tangential) + deallocate(ry_tang_rad) endif if (segment%oblique_tan .or. segment%oblique_grad) then J=segment%HI%JsdB - allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) - allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(rx_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tang_obl(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz if (gamma_u < 1.0) then - rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) - ry_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) - ry_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + rx_tang_obl(segment%HI%IsdB,J,k) = segment%rx_norm_obl(segment%HI%isd,J,k) + rx_tang_obl(segment%HI%IedB,J,k) = segment%rx_norm_obl(segment%HI%ied,J,k) + ry_tang_obl(segment%HI%IsdB,J,k) = segment%ry_norm_obl(segment%HI%isd,J,k) + ry_tang_obl(segment%HI%IedB,J,k) = segment%ry_norm_obl(segment%HI%ied,J,k) cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) - ry_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + rx_tang_obl(I,J,k) = 0.5*(segment%rx_norm_obl(i,J,k) + segment%rx_norm_obl(i+1,J,k)) + ry_tang_obl(I,J,k) = 0.5*(segment%ry_norm_obl(i,J,k) + segment%ry_norm_obl(i+1,J,k)) cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) enddo else @@ -2749,19 +2821,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = US%L_T_to_m_s**2*dhdt*dhdy - cff_new = US%L_T_to_m_s**2*max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(cff_new,max(US%L_T_to_m_s**2*dhdt*dhdx,-cff_new)) - rx_tangential(I,j,k) = rx_new - ry_tangential(i,J,k) = ry_new + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) + rx_tang_obl(I,j,k) = rx_new + ry_tang_obl(i,J,k) = ry_new cff_tangential(i,J,k) = cff_new enddo endif enddo if (segment%oblique_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + ry_avg*u_new(I,j+2,k)) - & (max(rx_avg,0.0)*segment%grad_tan(i,2,k) + & @@ -2772,13 +2844,13 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + segment%tangential_vel(I,J,k) = (1.0 - gamma_2) * segment%tangential_vel(I,J,k) + & gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo ; enddo endif @@ -2786,8 +2858,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) Is_obc = max(segment%HI%IsdB,G%isd+1) Ie_obc = min(segment%HI%IedB,G%ied-1) do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_avg = rx_tangential(I,J,k) - ry_avg = ry_tangential(I,J,k) + rx_avg = rx_tang_obl(I,J,k) + ry_avg = ry_tang_obl(I,J,k) cff_avg = cff_tangential(I,J,k) segment%tangential_grad(I,J,k) = & ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & @@ -2800,18 +2872,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (segment%nudged_grad) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB ! dhdt gets set to 0 on inflow in oblique case - if (ry_tangential(I,J,k) <= 0.0) then + if (ry_tang_obl(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + segment%tangential_grad(I,J,k) = (1.0 - gamma_2) * segment%tangential_grad(I,J,k) + & gamma_2 * segment%nudged_tangential_grad(I,J,k) enddo ; enddo endif - deallocate(rx_tangential) - deallocate(ry_tangential) + deallocate(rx_tang_obl) + deallocate(ry_tang_obl) deallocate(cff_tangential) endif endif @@ -3125,7 +3197,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke)); segment%h(:,:,:)=0.0 allocate(segment%eta(IsdB:IedB,jsd:jed)); segment%eta(:,:)=0.0 if (segment%radiation) then - allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%rx_norm_rad(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_norm_rad(:,:,:)=0.0 endif allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(IsdB:IedB,jsd:jed)); segment%normal_vel_bt(:,:)=0.0 @@ -3149,8 +3221,8 @@ subroutine allocate_OBC_segment_data(OBC, segment) endif if (segment%oblique) then allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 - allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 - allocate(segment%ry_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%rx_norm_obl(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_norm_obl(:,:,:)=0.0 + allocate(segment%ry_norm_obl(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_norm_obl(:,:,:)=0.0 allocate(segment%cff_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif if (segment%oblique_tan) then @@ -3168,7 +3240,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke)); segment%h(:,:,:)=0.0 allocate(segment%eta(isd:ied,JsdB:JedB)); segment%eta(:,:)=0.0 if (segment%radiation) then - allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%ry_norm_rad(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_norm_rad(:,:,:)=0.0 endif allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(isd:ied,JsdB:JedB)); segment%normal_vel_bt(:,:)=0.0 @@ -3192,8 +3264,8 @@ subroutine allocate_OBC_segment_data(OBC, segment) endif if (segment%oblique) then allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 - allocate(segment%rx_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_normal(:,:,:)=0.0 - allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%rx_norm_obl(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_norm_obl(:,:,:)=0.0 + allocate(segment%ry_norm_obl(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_norm_obl(:,:,:)=0.0 allocate(segment%cff_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%cff_normal(:,:,:)=0.0 endif if (segment%oblique_tan) then @@ -3219,8 +3291,10 @@ subroutine deallocate_OBC_segment_data(OBC, segment) if (associated (segment%Htot)) deallocate(segment%Htot) if (associated (segment%h)) deallocate(segment%h) if (associated (segment%eta)) deallocate(segment%eta) - if (associated (segment%rx_normal)) deallocate(segment%rx_normal) - if (associated (segment%ry_normal)) deallocate(segment%ry_normal) + if (associated (segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) + if (associated (segment%ry_norm_rad)) deallocate(segment%ry_norm_rad) + if (associated (segment%rx_norm_obl)) deallocate(segment%rx_norm_obl) + if (associated (segment%ry_norm_obl)) deallocate(segment%ry_norm_obl) if (associated (segment%cff_normal)) deallocate(segment%cff_normal) if (associated (segment%grad_normal)) deallocate(segment%grad_normal) if (associated (segment%grad_tan)) deallocate(segment%grad_tan) @@ -3244,8 +3318,8 @@ end subroutine deallocate_OBC_segment_data subroutine open_boundary_test_extern_uv(G, OBC, u, v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)),intent(inout) :: u !< Zonal velocity [m s-1] - real, dimension(SZI_(G),SZJB_(G), SZK_(G)),intent(inout) :: v !< Meridional velocity [m s-1] + real, dimension(SZIB_(G),SZJ_(G), SZK_(G)),intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G), SZK_(G)),intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] ! Local variables integer :: i, j, k, n @@ -3284,37 +3358,41 @@ end subroutine open_boundary_test_extern_uv !> Set thicknesses outside of open boundaries to silly values !! (used for checking the interior state is independent of values outside !! of the domain). -subroutine open_boundary_test_extern_h(G, OBC, h) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)),intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] +subroutine open_boundary_test_extern_h(G, GV, OBC, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)),intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] ! Local variables + real :: silly_h ! A silly thickness for testing [H ~> m or kg m-2] integer :: i, j, k, n if (.not. associated(OBC)) return + silly_h = GV%Z_to_H*OBC%silly_h + do n = 1, OBC%number_of_segments - do k = 1, G%ke + do k = 1, GV%ke if (OBC%segment(n)%is_N_or_S) then J = OBC%segment(n)%HI%JsdB if (OBC%segment(n)%direction == OBC_DIRECTION_N) then do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h(i,j+1,k) = OBC%silly_h + h(i,j+1,k) = silly_h enddo else do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h(i,j,k) = OBC%silly_h + h(i,j,k) = silly_h enddo endif elseif (OBC%segment(n)%is_E_or_W) then I = OBC%segment(n)%HI%IsdB if (OBC%segment(n)%direction == OBC_DIRECTION_E) then do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h(i+1,j,k) = OBC%silly_h + h(i+1,j,k) = silly_h enddo else do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h(i,j,k) = OBC%silly_h + h(i,j,k) = silly_h enddo endif endif @@ -3388,7 +3466,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%direction == OBC_DIRECTION_W) ishift=1 I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - segment%Cg(I,j) = US%L_T_to_m_s*sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) + segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) segment%Htot(I,j)=0.0 do k=1,G%ke segment%h(I,j,k) = h(i+ishift,j,k) @@ -3401,7 +3479,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%direction == OBC_DIRECTION_S) jshift=1 J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%Cg(i,J) = US%L_T_to_m_s*sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) + segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) segment%Htot(i,J)=0.0 do k=1,G%ke segment%h(i,J,k) = h(i,j+jshift,k) @@ -3647,7 +3725,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif else ! 2d data - segment%field(m)%buffer_dst(:,:,1)=segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer + segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer endif deallocate(tmp_buffer) else ! fid <= 0 (Uniform value) @@ -3681,9 +3759,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) endif endif - segment%field(m)%buffer_dst(:,:,:)=segment%field(m)%value + segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then - segment%field(m)%bt_vel(:,:)=segment%field(m)%value + segment%field(m)%bt_vel(:,:) = segment%field(m)%value endif endif endif @@ -4355,7 +4433,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart "uninitialized OBC control structure") if (associated(OBC%rx_normal) .or. associated(OBC%ry_normal) .or. & - associated(OBC%cff_normal)) & + associated(OBC%rx_oblique) .or. associated(OBC%ry_oblique) .or. associated(OBC%cff_normal)) & call MOM_error(FATAL, "open_boundary_register_restarts: Restart "//& "arrays were previously allocated") @@ -4367,20 +4445,28 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! 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%radiation_BCs_exist_globally .or. OBC%oblique_BCs_exist_globally) then + if (OBC%radiation_BCs_exist_globally) then allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) OBC%rx_normal(:,:,:) = 0.0 - vd = var_desc("rx_normal","m s-1", "Normal Phase Speed for EW OBCs",'u','L') + vd = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') call register_restart_field(OBC%rx_normal, vd, .false., restart_CSp) allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) OBC%ry_normal(:,:,:) = 0.0 - vd = var_desc("ry_normal","m s-1", "Normal Phase Speed for NS OBCs",'v','L') + vd = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') call register_restart_field(OBC%ry_normal, vd, .false., restart_CSp) endif if (OBC%oblique_BCs_exist_globally) then + allocate(OBC%rx_oblique(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) + OBC%rx_oblique(:,:,:) = 0.0 + vd = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + call register_restart_field(OBC%rx_oblique, vd, .false., restart_CSp) + allocate(OBC%ry_oblique(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) + OBC%ry_oblique(:,:,:) = 0.0 + vd = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_field(OBC%ry_oblique, vd, .false., restart_CSp) allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) OBC%cff_normal(:,:,:) = 0.0 - vd = var_desc("cff_normal","m s-1", "denominator for oblique OBCs",'q','L') + vd = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') call register_restart_field(OBC%cff_normal, vd, .false., restart_CSp) endif @@ -4396,8 +4482,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! This would be coming from user code such as DOME. if (OBC%ntr /= Reg%ntr) then ! call MOM_error(FATAL, "open_boundary_regiser_restarts: Inconsistent value for ntr") - write(mesg,'("Inconsisten values for ntr ",'// & - 'I8," and ",I8,".")') OBC%ntr, Reg%ntr + write(mesg,'("Inconsistent values for ntr ", I8," and ",I8,".")') OBC%ntr, Reg%ntr call MOM_error(WARNING, 'open_boundary_register_restarts: '//mesg) endif endif @@ -4439,75 +4524,68 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness after advection !! [H ~> m or kg m-2] type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, intent(in) :: dt !< time increment [s] + real, intent(in) :: dt !< time increment [T ~> s] type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry ! Local variables + type(OBC_segment_type), pointer :: segment=>NULL() + real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell [L ~> m] + real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell [L ~> m] + real :: fac1 ! The denominator of the expression for tracer updates [nondim] integer :: i, j, k, m, n, ntr, nz integer :: ishift, idir, jshift, jdir - type(OBC_segment_type), pointer :: segment=>NULL() - real :: u_L_in, u_L_out - real :: v_L_in, v_L_out - real :: fac1 nz = GV%ke ntr = Reg%ntr - if (associated(OBC)) then ; if (OBC%OBC_pe) then - do n=1,OBC%number_of_segments - segment=>OBC%segment(n) - if (.not. associated(segment%tr_Reg)) cycle - if (segment%is_E_or_W) then - do j=segment%HI%jsd,segment%HI%jed - I = segment%HI%IsdB - ishift=0 ! ishift+I corresponds to the nearest interior tracer cell index - idir=1 ! idir switches the sign of the flow so that positive is into the reservoir - if (segment%direction == OBC_DIRECTION_W) then - ishift=1 - idir=-1 - endif - ! update the reservoir tracer concentration implicitly - ! using Backward-Euler timestep - do m=1,ntr - if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,nz - u_L_out=max((idir*uhr(I,j,k))*segment%Tr_InvLscale_out/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) - u_L_in=min((idir*uhr(I,j,k))*segment%Tr_InvLscale_in/(h(i+ishift,j,k)*G%dyCu(I,j)),0.) - fac1=1.0+dt*(u_L_out-u_L_in) - segment%tr_Reg%Tr(m)%tres(I,j,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & - dt*(u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & - u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) - if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) - enddo - endif - enddo - enddo - else - do i=segment%HI%isd,segment%HI%ied - J = segment%HI%JsdB - jshift=0 ! jshift+J corresponds to the nearest interior tracer cell index - jdir=1 ! jdir switches the sign of the flow so that positive is into the reservoir - if (segment%direction == OBC_DIRECTION_S) then - jshift=1 - jdir=-1 - endif - ! update the reservoir tracer concentration implicitly - ! using Backward-Euler timestep - do m=1,ntr - if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,nz - v_L_out=max((jdir*vhr(i,J,k))*segment%Tr_InvLscale_out/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) - v_L_in=min((jdir*vhr(i,J,k))*segment%Tr_InvLscale_in/(h(i,j+jshift,k)*G%dxCv(i,J)),0.) - fac1=1.0+dt*(v_L_out-v_L_in) - segment%tr_Reg%Tr(m)%tres(i,J,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & - dt*(v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & - v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) - if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) - enddo - endif - enddo - enddo - endif - enddo - endif; endif + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. associated(segment%tr_Reg)) cycle + if (segment%is_E_or_W) then + do j=segment%HI%jsd,segment%HI%jed + I = segment%HI%IsdB + ! ishift+I corresponds to the nearest interior tracer cell index + ! idir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_W) then + ishift = 1 ; idir = -1 + else + ishift = 0 ; idir = 1 + endif + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / (h(i+ishift,j,k)*G%dyCu(I,j))) + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / (h(i+ishift,j,k)*G%dyCu(I,j))) + !### fac1 is dimensionally inconsistent in time, as is the tracer update expression. + fac1 = 1.0 + G%US%T_to_s*dt*(u_L_out-u_L_in) + segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & + G%US%T_to_s*dt*(u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & + u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) + if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; endif ; enddo + enddo + else + do i=segment%HI%isd,segment%HI%ied + J = segment%HI%JsdB + ! jshift+J corresponds to the nearest interior tracer cell index + ! jdir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_S) then + jshift = 1 ; jdir = -1 + else + jshift = 0 ; jdir = 1 + endif + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / (h(i,j+jshift,k)*G%dxCv(i,J))) + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / (h(i,j+jshift,k)*G%dxCv(i,J))) + !### fac1 is dimensionally inconsistent in time, as is the tracer update expression. + fac1 = 1.0 + G%US%T_to_s*dt*(v_L_out-v_L_in) + segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & + G%US%T_to_s*dt*(v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & + v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) + if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; endif ; enddo + enddo + endif + enddo ; endif ; endif + end subroutine update_segment_tracer_reservoirs !> Adjust interface heights to fit the bathymetry and diagnose layer thickness. diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index f7c48778a0..fadd6428c5 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -562,7 +562,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & endif ! Reads OBC parameters not pertaining to the location of the boundaries - call open_boundary_init(G, PF, OBC) + call open_boundary_init(G, GV, US, PF, OBC, restart_CS) ! This controls user code for setting open boundary data if (associated(OBC)) then @@ -616,7 +616,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call qchksum(G%mask2dBu, 'MOM_initialize_state: mask2dBu ', G%HI) endif - if (debug_OBC) call open_boundary_test_extern_h(G, OBC, h) + if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) call callTree_leave('MOM_initialize_state()') end subroutine MOM_initialize_state From 98e145089d083b60230a6e4d3d72a0371d6d4d6f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 26 Nov 2019 10:27:40 -0500 Subject: [PATCH 237/259] (*)Fixed invariance bugs in MOM_open_boundary.F90 Corrected dimensional consistency bugs in update_segment_tracer_reservoirs and horizontal indexing and related bugs in gradient_at_q_points with oblique_grad OBCs. These will both change answers in test cases that use some open boundary condition options, but not in any of the MOM6-examples test cases. --- src/core/MOM_open_boundary.F90 | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c6101f2f31..f35748dd4a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -768,10 +768,8 @@ subroutine initialize_segment_data(G, OBC, PF) segment%field(m)%name = trim(fields(m)) if (segment%field(m)%name == 'U') then segment%u_values_needed = .false. - !### segment%field(m)%value = US%m_s_to_L_T*segment%field(m)%value elseif (segment%field(m)%name == 'V') then segment%v_values_needed = .false. - !### segment%field(m)%value = US%m_s_to_L_T*segment%field(m)%value elseif (segment%field(m)%name == 'SSH') then segment%z_values_needed = .false. elseif (segment%field(m)%name == 'TEMP') then @@ -780,7 +778,6 @@ subroutine initialize_segment_data(G, OBC, PF) segment%s_values_needed = .false. elseif (segment%field(m)%name == 'DVDX' .or. segment%field(m)%name == 'DUDY') then segment%g_values_needed = .false. - !### segment%field(m)%value = US%T_to_s*segment%field(m)%value endif endif enddo @@ -2995,9 +2992,9 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) do k=1,G%ke do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) segment%grad_gradient(j,1,k) = (((vvel(i-1,J,k) - vvel(i-2,J,k))*G%IdxBu(I-2,J)) - & - (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-1,j) + (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-2,j) segment%grad_gradient(j,2,k) = (((vvel(i,J,k) - vvel(i-1,J,k))*G%IdxBu(I-1,J)) - & - (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I,j) + (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I-1,j) enddo enddo endif @@ -3048,11 +3045,10 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) if (segment%oblique_grad) then do k=1,G%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) - !### The combination of differences in j and Idx here do not make sense to me. All should be Idy? - segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdxBu(I,J-2)) - & - (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdxBu(I-1,J-2)) * G%mask2dCv(I,j-1) + segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdyBu(I,J-2)) - & + (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2)) * G%mask2dCv(i,J-2) segment%grad_gradient(i,2,k) = (((uvel(I,j,k) - uvel(I,j-1,k))*G%IdyBu(I,J-1)) - & - (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J) + (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J-1) enddo enddo endif @@ -3075,10 +3071,9 @@ subroutine gradient_at_q_points(G, segment, uvel, vvel) if (segment%oblique_grad) then do k=1,G%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) - !### The combination of differences in j and Idx here do not make sense to me. All should be Idy? - segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdxBu(I,J+2)) - & + segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdyBu(I,J+2)) - & (uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2)) * G%mask2dCv(i,J+2) - segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdxBu(I,J+1)) - & + segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdyBu(I,J+1)) - & (uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1)) * G%mask2dCv(i,J+1) enddo enddo @@ -4553,10 +4548,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / (h(i+ishift,j,k)*G%dyCu(I,j))) u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / (h(i+ishift,j,k)*G%dyCu(I,j))) - !### fac1 is dimensionally inconsistent in time, as is the tracer update expression. - fac1 = 1.0 + G%US%T_to_s*dt*(u_L_out-u_L_in) + fac1 = 1.0 + (u_L_out-u_L_in) segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & - G%US%T_to_s*dt*(u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & + (u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) enddo ; endif ; enddo @@ -4575,10 +4569,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) do m=1,ntr ; if (associated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / (h(i,j+jshift,k)*G%dxCv(i,J))) v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / (h(i,j+jshift,k)*G%dxCv(i,J))) - !### fac1 is dimensionally inconsistent in time, as is the tracer update expression. - fac1 = 1.0 + G%US%T_to_s*dt*(v_L_out-v_L_in) + fac1 = 1.0 + (v_L_out-v_L_in) segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & - G%US%T_to_s*dt*(v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & + (v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) enddo ; endif ; enddo From 4edc165ed2f63f92150ea11c8c5a739f88fb0891 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 1 Dec 2019 08:54:01 -0500 Subject: [PATCH 238/259] (*)Fixed dimensional inconsistency in P3M_functions Corrected dimensionally inconsistent expressions in P3M_functions.F90, notably in P3M_limiter and monotonize_cubic and a complete rewrite and simplification of is_cubic_monotonic. Also added comments documenting the units of all real variables in this module, and changed the code to use logical variables in place of integer "booleans", including in the return value from is_cubic_monotonic. These changes will change (fix) the answers when remapping variables with small numerical values, but no answers change in the MOM6-examples test cases. --- src/ALE/P3M_functions.F90 | 261 +++++++++++++++----------------------- 1 file changed, 99 insertions(+), 162 deletions(-) diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 1964cd25dd..da3fe5bb6b 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -25,20 +25,15 @@ module P3M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & - h_neglect ) +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) 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, - !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly - !! with the same units as u. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. + !! purpose of cell reconstructions [H] ! Call the limiter for p3m, which takes care of everything from ! computing the coefficients of the cubic to monotonizing it. @@ -64,28 +59,24 @@ end subroutine P3M_interpolation !! Step 3 of the monotonization process leaves all edge values unchanged. subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) 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, - !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. + !! the purpose of cell reconstructions [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 + logical :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0_l, u0_r ! edge values [A] + real :: u1_l, u1_r ! edge slopes [A H-1] + real :: u_l, u_c, u_r ! left, center and right cell averages [A] + real :: h_l, h_c, h_r ! left, center and right cell widths [H] + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] + real :: slope ! retained PLM slope [A H-1] real :: eps - real :: hNeglect + real :: hNeglect ! A negligibly small thickness [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -142,16 +133,9 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) slope = 0.0 endif - ! 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. These expressions are both nondimensional. - if ( abs(u1_l*h_c) < eps ) then - u1_l = 0.0 - endif - - if ( abs(u1_r*h_c) < eps ) then - u1_r = 0.0 - endif + ! If the slopes are small, set them to zero to prevent asymmetric representation near extrema. + if ( abs(u1_l*h_c) < epsilon(u_c)*abs(u_c) ) u1_l = 0.0 + if ( abs(u1_r*h_c) < epsilon(u_c)*abs(u_c) ) u1_r = 0.0 ! The edge slopes are limited from above by the respective ! one-sided slopes @@ -172,7 +156,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) ! If cubic is not monotonic, monotonize it by modifiying the ! edge slopes, store the new edge slopes and recompute the ! cubic coefficients - if ( monotonic == 0 ) then + if ( .not.monotonic ) then call monotonize_cubic( h_c, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) endif @@ -204,30 +188,25 @@ end subroutine P3M_limiter subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) 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, - !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly - !! with the same units as u. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. + !! purpose of cell reconstructions [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. + !! for the purpose of finding edge values [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 :: slope - real :: hNeglect, hNeglect_edge + logical :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0, u1 ! Values of u in two adjacent cells [A] + real :: h0, h1 ! Values of h in two adjacent cells, plus a smal increment [H] + real :: b, c, d ! Temporary variables [A] + real :: u0_l, u0_r ! Left and right edge values [A] + real :: u1_l, u1_r ! Left and right edge slopes [A H-1] + real :: slope ! The cell center slope [A H-1] + real :: hNeglect, hNeglect_edge ! Negligibly small thickness [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = hNeglect_edge_dflt @@ -281,7 +260,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i0 ) - if ( monotonic == 0 ) then + if ( .not.monotonic ) then call monotonize_cubic( h0, u0_l, u0_r, 0.0, slope, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization @@ -340,7 +319,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i1 ) - if ( monotonic == 0 ) then + if ( .not.monotonic ) then call monotonize_cubic( h1, u0_l, u0_r, slope, 0.0, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization @@ -360,19 +339,17 @@ end subroutine P3M_boundary_extrapolation !! NOTE: edge values and slopes MUST have been properly calculated prior to !! calling this routine. subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) - real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] integer, intent(in) :: k !< The index of the cell to work on - real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial, - !! with the same units as u. - real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial, - !! in the units of u over the units of h. - real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly - !! with the same units as u. + real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial in arbitrary units [A] + real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] + ! Local variables - real :: u0_l, u0_r ! edge values - real :: u1_l, u1_r ! edge slopes - real :: h_c ! cell width - real :: a0, a1, a2, a3 ! cubic coefficients + real :: u0_l, u0_r ! edge values [A] + real :: u1_l, u1_r ! edge slopes times the cell width [A] + real :: h_c ! cell width [H] + real :: a0, a1, a2, a3 ! cubic coefficients [A] h_c = h(k) @@ -400,63 +377,30 @@ end subroutine build_cubic_interpolant !! This function checks whether the cubic curve in cell k is monotonic. !! If so, returns 1. Otherwise, returns 0. !! -!! The cubic is monotonic if the first derivative is single-signed in [0,1]. +!! The cubic is monotonic if the first derivative is single-signed in (0,1). !! Hence, we check whether the roots (if any) lie inside this interval. If there !! is no root or if both roots lie outside this interval, the cubic is monotonic. -integer function is_cubic_monotonic( ppoly_coef, k ) - real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial +logical function is_cubic_monotonic( ppoly_coef, k ) + real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial in arbitary units [A] integer, intent(in) :: k !< The index of the cell to work on ! Local variables - integer :: monotonic ! boolean indicating if monotonic or not - real :: a0, a1, a2, a3 ! cubic coefficients - real :: a, b, c ! coefficients of first derivative - real :: xi_0, xi_1 ! roots of first derivative (if any !) - real :: rho - real :: eps - - ! Define the radius of the ball around 0 and 1 in which all values are assumed - ! to be equal to 0 or 1, respectively - eps = 1e-14 - - a0 = ppoly_coef(k,1) - a1 = ppoly_coef(k,2) - a2 = ppoly_coef(k,3) - a3 = ppoly_coef(k,4) - - a = a1 - b = 2.0 * a2 - c = 3.0 * a3 - - xi_0 = -1.0 - xi_1 = -1.0 - - rho = b*b - 4.0*a*c - - if ( rho >= 0.0 ) then - if ( abs(c) > 1e-15 ) then - xi_0 = 0.5 * ( -b - sqrt( rho ) ) / c - xi_1 = 0.5 * ( -b + sqrt( rho ) ) / c - elseif ( abs(b) > 1e-15 ) then - xi_0 = - a / b - xi_1 = - a / b - endif - - ! If one of the roots of the first derivative lies in (0,1), - ! the cubic is not monotonic. - if ( ( (xi_0 > eps) .AND. (xi_0 < 1.0-eps) ) .OR. & - ( (xi_1 > eps) .AND. (xi_1 < 1.0-eps) ) ) then - monotonic = 0 - else - monotonic = 1 - endif - - else ! there are no real roots --> cubic is monotonic - monotonic = 1 + real :: a, b, c ! Coefficients of the first derivative of the cubic [A] + + a = ppoly_coef(k,2) + b = 2.0 * ppoly_coef(k,3) + c = 3.0 * ppoly_coef(k,4) + + ! Look for real roots of the quadratic derivative equation, c*x**2 + b*x + a = 0, in (0, 1) + if (b*b - 4.0*a*c <= 0.0) then ! The cubic is monotonic everywhere. + is_cubic_monotonic = .true. + elseif (a * (a + (b + c)) < 0.0) then ! The derivative changes sign between the endpoints of (0, 1) + is_cubic_monotonic = .false. + elseif (b * (b + 2.0*c) < 0.0) then ! The second derivative changes sign inside of (0, 1) + is_cubic_monotonic = .false. + else + is_cubic_monotonic = .true. endif - ! Set the return value - is_cubic_monotonic = monotonic - end function is_cubic_monotonic !> Monotonize a cubic curve by modifying the edge slopes. @@ -487,30 +431,27 @@ end function is_cubic_monotonic !! edge or onto the right edge. subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) - real, intent(in) :: h !< cell width - real, intent(in) :: u0_l !< left edge value - real, intent(in) :: u0_r !< right edge value - real, intent(in) :: sigma_l !< left 2nd-order slopes - real, intent(in) :: sigma_r !< right 2nd-order slopes - real, intent(in) :: slope !< limited PLM slope - real, intent(inout) :: u1_l !< left edge slopes - real, intent(inout) :: u1_r !< right edge slopes + real, intent(in) :: h !< cell width [H] + real, intent(in) :: u0_l !< left edge value in arbitrary units [A] + real, intent(in) :: u0_r !< right edge value [A] + real, intent(in) :: sigma_l !< left 2nd-order slopes [A H-1] + real, intent(in) :: sigma_r !< right 2nd-order slopes [A H-1] + real, intent(in) :: slope !< limited PLM slope [A H-1] + real, intent(inout) :: u1_l !< left edge slopes [A H-1] + real, intent(inout) :: u1_r !< right edge slopes [A H-1] ! Local variables - integer :: found_ip - integer :: inflexion_l ! bool telling if inflex. pt must be on left - integer :: inflexion_r ! bool telling if inflex. pt must be on right - real :: eps - real :: a1, a2, a3 - real :: u1_l_tmp ! trial left edge slope - real :: u1_r_tmp ! trial right edge slope - real :: xi_ip ! location of inflexion point - real :: slope_ip ! slope at inflexion point - - eps = 1e-14 - - found_ip = 0 - inflexion_l = 0 - inflexion_r = 0 + logical :: found_ip + logical :: inflexion_l ! bool telling if inflex. pt must be on left + logical :: inflexion_r ! bool telling if inflex. pt must be on right + real :: a1, a2, a3 ! Temporary slopes times the cell width [A] + real :: u1_l_tmp ! trial left edge slope [A H-1] + real :: u1_r_tmp ! trial right edge slope [A H-1] + real :: xi_ip ! location of inflexion point in cell coordinates (0,1) [nondim] + real :: slope_ip ! slope at inflexion point times cell width [A] + + found_ip = .false. + inflexion_l = .false. + inflexion_r = .false. ! If the edge slopes are inconsistent w.r.t. the limited PLM slope, ! set them to zero @@ -537,7 +478,7 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! If the inflexion point lies in [0,1], change boolean value if ( (xi_ip >= 0.0) .AND. (xi_ip <= 1.0) ) then - found_ip = 1 + found_ip = .true. endif endif @@ -546,25 +487,25 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! decide on which side we want to collapse the inflexion point. ! If the inflexion point lies on one of the edges, the cubic is ! guaranteed to be monotonic - if ( found_ip == 1 ) then + if ( found_ip ) then slope_ip = a1 + 2.0*a2*xi_ip + 3.0*a3*xi_ip*xi_ip ! Check whether slope is consistent if ( slope_ip*slope < 0.0 ) then if ( abs(sigma_l) < abs(sigma_r) ) then - inflexion_l = 1 + inflexion_l = .true. else - inflexion_r = 1 + inflexion_r = .true. endif endif endif ! found_ip ! At this point, if the cubic is not monotonic, we know where the ! inflexion point should lie. When the cubic is monotonic, both - ! 'inflexion_l' and 'inflexion_r' are set to 0 and nothing is to be done. + ! 'inflexion_l' and 'inflexion_r' are false and nothing is to be done. ! Move inflexion point on the left - if ( inflexion_l == 1 ) then + if ( inflexion_l ) then u1_l_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_r u1_r_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_l @@ -594,7 +535,7 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r endif ! end treating case with inflexion point on the left ! Move inflexion point on the right - if ( inflexion_r == 1 ) then + if ( inflexion_r ) then u1_l_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_r u1_r_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_l @@ -623,13 +564,9 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r endif ! end treating case with inflexion point on the right - if ( abs(u1_l*h) < eps ) then - u1_l = 0.0 - endif - - if ( abs(u1_r*h) < eps ) then - u1_r = 0.0 - endif + ! Zero out negligibly small slopes. + if ( abs(u1_l*h) < epsilon(u0_l) * (abs(u0_l) + abs(u0_r)) ) u1_l = 0.0 + if ( abs(u1_r*h) < epsilon(u0_l) * (abs(u0_l) + abs(u0_r)) ) u1_r = 0.0 end subroutine monotonize_cubic From e9ee86ac501c248a812a64255674b8ed2d2f5b7d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 2 Dec 2019 13:29:05 -0500 Subject: [PATCH 239/259] +Added REMAPPING_2018 runtime option Added a new runtime option, REMAPPING_2018, which if set to false triggers the use of new, more accurate expressions in various parts of the ALE remapping code. By default, the older expressions are used, and all answers are bitwise identical, but there are new optional arguments to various routines related to remapping to trigger the use of new mathematically equivalent expressions. By default all answers are bitwise identical, but there are new and reordered entries in the MOM6_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 43 +++++-- src/ALE/MOM_remapping.F90 | 37 ++++-- src/ALE/regrid_edge_slopes.F90 | 142 ++++++++++++-------- src/ALE/regrid_edge_values.F90 | 229 ++++++++++++++++++++------------- src/ALE/regrid_interp.F90 | 60 ++++++--- 5 files changed, 318 insertions(+), 193 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index d7917f8cad..97232b22ca 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -63,9 +63,9 @@ module MOM_ALE !> ALE control structure type, public :: ALE_CS ; private - logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" - !! method. If False, uses the new method that - !! remaps between grids described by h. + logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" + !! method. If False, uses the new method that + !! remaps between grids described by h. real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid !! and the target (new) grid [T ~> s] @@ -73,9 +73,13 @@ module MOM_ALE type(regridding_CS) :: regridCS !< Regridding parameters and work arrays type(remapping_CS) :: remapCS !< Remapping parameters and work arrays - integer :: nk !< Used only for queries, not directly by this module + integer :: nk !< Used only for queries, not directly by this module - logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. + logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. + + logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping + !! that recover the answers from the end of 2018. Otherwise, use more + !! robust and accurate forms of mathematically equivalent expressions. logical :: show_call_tree !< For debugging @@ -145,6 +149,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) character(len=40) :: mdl = "MOM_ALE" ! This module's name. character(len=80) :: string ! Temporary strings real :: filter_shallow_depth, filter_deep_depth + logical :: default_2018_answers logical :: check_reconstruction logical :: check_remapping logical :: force_bounds_in_subcell @@ -192,11 +197,19 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & "If true, values at the interfaces of boundary cells are "//& "extrapolated instead of piecewise constant", default=.false.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=remap_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell) + force_bounds_in_subcell=force_bounds_in_subcell, & + answers_2018=CS%answers_2018) call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & "If true, applies regridding and remapping immediately after "//& @@ -220,7 +233,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "REGRID_FILTER_SHALLOW_DEPTH the filter weights adopt a cubic profile.", & units="m", default=0., scale=GV%m_to_H) call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, & - depth_of_time_filter_deep=filter_deep_depth) + depth_of_time_filter_deep=filter_deep_depth) call get_param(param_file, mdl, "REGRID_USE_OLD_DIRECTION", local_logical, & "If true, the regridding ntegrates upwards from the bottom for "//& "interface positions, much as the main model does. If false "//& @@ -1089,13 +1102,13 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) - real :: tmp(GV%ke) + real :: hTmp(GV%ke) ! A 1-d copy of h [H ~> m or kg m-2] + real :: tmp(GV%ke) ! A 1-d copy of a column of temperature [degC] or salinity [ppt] real, dimension(CS%nk,2) :: & - ppol_E !Edge value of polynomial + ppol_E ! Edge value of polynomial in [degC] or [ppt] real, dimension(CS%nk,3) :: & - ppol_coefs !Coefficients of polynomial - real :: h_neglect, h_neglect_edge + ppol_coefs ! Coefficients of polynomial, all in [degC] or [ppt] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses [H ~> m or kg m-2] !### Try replacing both of these with GV%H_subroundoff if (GV%Boussinesq) then @@ -1116,7 +1129,8 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ppol_E(:,:) = 0.0 ppol_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, ppol_E, h_neglect=h_neglect_edge ) + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge, & + answers_2018=CS%answers_2018 ) call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) if (bdry_extrap) & call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) @@ -1131,7 +1145,8 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ppol_coefs(:,:) = 0.0 tmp(:) = tv%T(i,j,:) !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H ) + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H, & + answers_2018=CS%answers_2018 ) call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) if (bdry_extrap) & call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index f399aa2c0f..d7f8343993 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -33,6 +33,8 @@ module MOM_remapping logical :: check_remapping = .false. !> If true, the intermediate values used in remapping are forced to be bounded. logical :: force_bounds_in_subcell = .false. + !> If true use older, less acccurate expressions. + logical :: answers_2018 = .true. end type ! The following routines are visible to the outside world @@ -84,13 +86,14 @@ module MOM_remapping !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell) + check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. if (present(remapping_scheme)) then call setReconstructionType( remapping_scheme, CS ) @@ -107,6 +110,9 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(force_bounds_in_subcell)) then CS%force_bounds_in_subcell = force_bounds_in_subcell endif + if (present(answers_2018)) then + CS%answers_2018 = answers_2018 + endif end subroutine remapping_set_param subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_extrapolation, check_reconstruction, & @@ -392,22 +398,22 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) - call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) - 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 edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & @@ -415,8 +421,8 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) - 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 edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & @@ -1537,7 +1543,7 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell) + check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018) ! Arguments type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), intent(in) :: remapping_scheme !< Remapping scheme to use @@ -1545,11 +1551,12 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. - ! Note that remapping_scheme is mandatory fir initialize_remapping() + ! Note that remapping_scheme is mandatory for initialize_remapping() call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell) + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) end subroutine initialize_remapping @@ -1615,6 +1622,7 @@ logical function remapping_unit_tests(verbose) data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 type(remapping_CS) :: CS !< Remapping control structure real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs + logical :: answers_2018 ! If true use older, less acccurate expressions. integer :: i real :: err, h_neglect, h_neglect_edge logical :: thisTest, v @@ -1622,6 +1630,7 @@ logical function remapping_unit_tests(verbose) v = verbose h_neglect = hNeglect_dflt h_neglect_edge = 1.0e-10 + answers_2018 = .true. write(*,*) '==== MOM_remapping: remapping_unit_tests =================' remapping_unit_tests = .false. ! Normally return false @@ -1643,7 +1652,7 @@ logical function remapping_unit_tests(verbose) remapping_unit_tests = remapping_unit_tests .or. thisTest thisTest = .false. - call initialize_remapping(CS, 'PPM_H4') + call initialize_remapping(CS, 'PPM_H4', answers_2018=answers_2018) if (verbose) write(*,*) 'h0 (test data)' if (verbose) call dumpGrid(n0,h0,x0,u0) @@ -1667,7 +1676,7 @@ logical function remapping_unit_tests(verbose) ppoly0_S(:,:) = 0.0 ppoly0_coefs(:,:) = 0.0 - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10 ) + call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answers_2018=answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) u1(:) = 0. @@ -1798,7 +1807,7 @@ logical function remapping_unit_tests(verbose) test_answer(v, 3, ppoly0_coefs(:,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 ) + h_neglect=1e-10, answers_2018=answers_2018 ) ! The next two tests currently fail due to roundoff. thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') @@ -1814,7 +1823,7 @@ logical function remapping_unit_tests(verbose) test_answer(v, 5, ppoly0_coefs(:,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 ) + h_neglect=1e-10, answers_2018=answers_2018 ) ! The next two tests currently fail due to roundoff. thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index c22a524683..8d5c055907 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -46,35 +46,39 @@ module regrid_edge_slopes !! !! There are N+1 unknowns and we are able to write N-1 equations. The !! boundary conditions close the system. -subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) 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, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1] real, optional, intent(in) :: h_neglect !< A negligibly small width + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths - real :: h0_2, h1_2, h0h1 - real :: h0_3, h1_3 - real :: d - real :: alpha, beta ! stencil coefficients - real :: a, b - real, dimension(5) :: x ! system used to enforce - real, dimension(4,4) :: Asys ! boundary conditions + real :: h0, h1 ! cell widths [H] + real :: h0_2, h1_2, h0h1 ! products of cell widths [H2] + real :: h0_3, h1_3 ! products of three cell widths [H3] + real :: d ! A demporary variable [H3] + real :: alpha, beta ! stencil coefficients [nondim] + real :: a, b ! weights of cells [H-1] + real, parameter :: C1_12 = 1.0 / 12.0 + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: dx, xavg ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! matrix used to find boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(3) :: Dsys - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - 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. + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (unknowns vector) [A H-1] + tri_x ! trid. system (rhs) [A H-1] + real :: hNeglect ! A negligible thickness [H]. + real :: hNeglect3 ! hNeglect^3 [H3]. + logical :: use_2018_answers ! If true use older, less acccurate expressions. hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect hNeglect3 = hNeglect**3 + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! Loop on cells (except last one) do i = 1,N-1 @@ -113,12 +117,18 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) enddo do i = 1,4 - - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * ( h(i) ) + dx = h(i) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif + + Bsys(i) = u(i) * dx enddo @@ -139,12 +149,17 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) enddo do i = 1,4 - - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-4+i) * ( h(N-4+i) ) + dx = h(N-4+i) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif + Bsys(i) = u(N-4+i) * dx enddo @@ -173,14 +188,13 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ !> Compute ih5 edge values (implicit fifth order accurate) -subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_2018 ) 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. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! ----------------------------------------------------------------------------- ! 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 @@ -232,8 +246,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) real :: h2ph3_3, h2ph3_4 ! ... real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " - real, dimension(7) :: x ! system used to enforce - real, dimension(6,6) :: Asys ! boundary conditions + real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] + real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C5_6 = 5.0 / 6.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real, dimension(6,6) :: Asys ! matrix used to find boundary conditions real, dimension(6) :: Bsys, Csys ! ... real, dimension(5) :: Dsys ! derivative real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) @@ -241,9 +258,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) 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 :: hNeglect ! A negligible thickness in the same units as h. + logical :: use_2018_answers ! If true use older, less acccurate expressions. hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! Loop on cells (except last one) do k = 2,N-2 @@ -473,11 +492,20 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) do i = 1,6 - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * h(i) + dx = h(i) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + + Bsys(i) = u(i) * dx enddo @@ -612,13 +640,19 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) enddo do i = 1,6 - - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-6+i) * h(N-6+i) - + dx = h(N-6+i) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + Bsys(i) = u(N-6+i) * dx enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index d27d69153c..4de17c88b4 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -46,23 +46,20 @@ module regrid_edge_values !! Therefore, boundary cells are treated as if they were local extrama. subroutine bound_edge_values( N, h, u, edge_val, 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) :: edge_val !< 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. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Potentially modified edge values [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] ! Local variables integer :: k ! loop index integer :: k0, k1, k2 - real :: h_l, h_c, h_r - real :: u_l, u_c, u_r - real :: u0_l, u0_r + real :: h_l, h_c, h_r ! Layer thicknesses [H] + real :: u_l, u_c, u_r ! Cell average properties [A] + real :: u0_l, u0_r ! Edge values of properties [A] real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes - real :: slope ! retained PLM slope - - real :: hNeglect ! A negligible thicness in the same units as h. + ! van Leer slopes [A H-1] + real :: slope ! retained PLM slope [A H-1] + real :: hNeglect ! A negligible thickness [H]. hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -175,15 +172,15 @@ end subroutine average_discontinuous_edge_values !! If so and if they are not monotonic, replace each edge value by their average. subroutine check_discontinuous_edge_values( N, u, edge_val ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: u !< cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values with the same units as u. + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values [A]. ! Local variables integer :: k ! loop index - real :: u0_minus ! left value at given edge - real :: u0_plus ! right value at given edge - real :: um_minus ! left cell average - real :: um_plus ! right cell average - real :: u0_avg ! avg value at given edge + real :: u0_minus ! left value at given edge [A] + real :: u0_plus ! right value at given edge [A] + real :: um_minus ! left cell average [A] + real :: um_plus ! right cell average [A] + real :: u0_avg ! avg value at given edge [A] ! Loop on interior cells do k = 1,N-1 @@ -227,16 +224,15 @@ end subroutine check_discontinuous_edge_values !! Boundary edge values are set to be equal to the boundary cell averages. subroutine edge_values_explicit_h2( N, h, u, edge_val, 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) :: edge_val !< 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 + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [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. + real :: h0, h1 ! cell widths [H] + real :: u0, u1 ! cell averages [A] + real :: hNeglect ! A negligible thickness [H] hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -289,24 +285,29 @@ end subroutine edge_values_explicit_h2 !! available interpolant. !! !! For this fourth-order scheme, at least four cells must exist. -subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) +subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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_val !< 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 + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: i, j - real :: u0, u1, u2, u3 - real :: h0, h1, h2, h3 - real :: f1, f2, f3 ! auxiliary variables + real :: u0, u1, u2, u3 ! temporary properties [A] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: f1, f2, f3 ! auxiliary variables with various units real :: e ! edge value - real, dimension(5) :: x ! used to compute edge + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, parameter :: C1_12 = 1.0 / 12.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] 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. + real :: hNeglect ! A negligible thickness in the same units as h. + logical :: use_2018_answers ! If true use older, less acccurate expressions. + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on interior cells @@ -372,12 +373,18 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 + dx = max(f1, h(i) ) + if (use_2018_answers) then + do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + A(i,1) = dx + A(i,2) = dx * xavg + A(i,3) = dx * (xavg**2 + C1_12*dx**2) + A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif - do j = 1,4 - A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - enddo - - B(i) = u(i) * max(f1, h(i) ) + B(i) = u(i) * dx enddo @@ -410,12 +417,18 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 + dx = max(f1, h(N-4+i) ) + if (use_2018_answers) then + do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + A(i,1) = dx + A(i,2) = dx * xavg + A(i,3) = dx * (xavg**2 + C1_12*dx**2) + A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif - do j = 1,4 - A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - enddo - - B(i) = u(N-4+i) * max(f1, h(N-4+i) ) + B(i) = u(N-4+i) * dx enddo @@ -475,21 +488,24 @@ end subroutine edge_values_explicit_h4 !! !! There are N+1 unknowns and we are able to write N-1 equations. The !! boundary conditions close the system. -subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) +subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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_val !< 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 + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths + real :: h0, h1 ! cell widths [H] real :: h0_2, h1_2, h0h1 real :: d2, d4 real :: alpha, beta ! stencil coefficients real :: a, b - real, dimension(5) :: x ! system used to enforce + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, parameter :: C1_12 = 1.0 / 12.0 + real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) @@ -497,8 +513,10 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) 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 :: hNeglect ! A negligible thickness [H] + logical :: use_2018_answers ! If true use older, less acccurate expressions. + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) @@ -543,12 +561,18 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 + dx = max(h0, h(i) ) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * max( h0, h(i) ) + Bsys(i) = u(i) * dx enddo @@ -566,12 +590,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) enddo do i = 1,4 - - do j = 1,4 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-4+i) * max( h0, h(N-4+i) ) + dx = max(h0, h(N-4+i) ) + if (use_2018_answers) then + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + endif + Bsys(i) = u(N-4+i) * dx enddo @@ -628,16 +657,17 @@ end subroutine edge_values_implicit_h4 !! become computationally expensive if regridding is carried out !! often. Figuring out closed-form expressions for these coefficients !! on nonuniform meshes turned out to be intractable. -subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) +subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) 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_val !< 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 + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(:,:), intent(inout) :: edge_val !!< Returned edge values [A]; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: i, j, k ! loop indexes - real :: h0, h1, h2, h3 ! cell widths + real :: h0, h1, h2, h3 ! cell widths [H] real :: g, g_2, g_3 ! the following are real :: g_4, g_5, g_6 ! auxiliary variables real :: d2, d3, d4, d5, d6 ! to set up the systems @@ -654,7 +684,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) real :: h0ph1_5, h2ph3_5 ! ... real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " - real, dimension(7) :: x ! system used to enforce + real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] + real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C5_6 = 5.0 / 6.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] real, dimension(6,6) :: Asys ! boundary conditions real, dimension(6) :: Bsys, Csys ! ... real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) @@ -662,8 +695,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) 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 :: hNeglect ! A negligible thickness [H]. + logical :: use_2018_answers ! If true use older, less acccurate expressions. + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) @@ -913,12 +948,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) enddo do i = 1,6 - - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(i) * max( g, h(i) ) + dx = max( g, h(i) ) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + Bsys(i) = u(i) * dx enddo @@ -1058,12 +1100,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) enddo do i = 1,6 - - do j = 1,6 - Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - enddo - - Bsys(i) = u(N-6+i) * max( g, h(N-6+i) ) + dx = max( g, h(N-6+i) ) + if (use_2018_answers) then + do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + else ! Use expressions with less sensitivity to roundoff + xavg = 0.5 * (x(i+1) + x(i)) + Asys(i,1) = dx + Asys(i,2) = dx * xavg + Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) + Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + endif + Bsys(i) = u(N-6+i) * dx enddo diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index d2c384c15e..ace311cc21 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -30,6 +30,9 @@ module regrid_interp !> Indicate whether high-order boundary extrapolation should be used within !! boundary cells logical :: boundary_extrapolation + + !> If true use older, less acccurate expressions. + logical :: answers_2018 = .true. end type interp_CS_type public regridding_set_ppolys, interpolate_grid @@ -112,7 +115,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) endif @@ -124,7 +127,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) endif @@ -143,7 +146,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -161,7 +164,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & @@ -179,8 +182,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_3 - 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 edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -199,8 +202,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_3 - 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 edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -219,8 +222,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_4 - 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 edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -239,8 +242,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_4 - 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 edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) if (extrapolate) then @@ -264,7 +267,7 @@ end subroutine regridding_set_ppolys !! '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_coefs, & - target_values, degree, n1, h1, x1 ) + target_values, degree, n1, h1, x1, answers_2018 ) 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 @@ -275,7 +278,10 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & 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 + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables + logical :: use_2018_answers ! If true use older, less acccurate expressions. integer :: k ! loop index real :: t ! current interface target density @@ -287,7 +293,8 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & ! 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_coefs, t, degree ) + x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree, & + answers_2018=answers_2018 ) h1(k-1) = x1(k) - x1(k-1) enddo h1(n1) = x1(n1+1) - x1(n1) @@ -320,7 +327,7 @@ subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, call regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, ppoly0_C, & degree, h_neglect, h_neglect_edge) call interpolate_grid(n0, h0, x0, ppoly0_E, ppoly0_C, target_values, degree, & - n1, h1, x1) + n1, h1, x1, answers_2018=CS%answers_2018) end subroutine build_and_interpolate_grid !> Given a target value, find corresponding coordinate for given polynomial @@ -340,7 +347,7 @@ 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_coefs, & - target_value, degree ) result ( x_tgt ) + target_value, degree, answers_2018 ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells real, dimension(:), intent(in) :: h !< Grid cell thicknesses @@ -349,6 +356,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & 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 + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. real :: x_tgt !< The position of x_g at which target_value is found. ! Local variables integer :: i, k ! loop indices @@ -363,9 +371,11 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & real :: eps ! offset used to get away from ! boundaries real :: grad ! gradient during N-R iterations + logical :: use_2018_answers ! If true use older, less acccurate expressions. eps = NR_OFFSET k_found = -1 + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or @@ -441,10 +451,14 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & exit endif - numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & - a(5)*xi0*xi0*xi0*xi0 - target_value - - denominator = a(2) + 2*a(3)*xi0 + 3*a(4)*xi0*xi0 + 4*a(5)*xi0*xi0*xi0 + if (use_2018_answers) then + numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & + a(5)*xi0*xi0*xi0*xi0 - target_value + denominator = a(2) + 2*a(3)*xi0 + 3*a(4)*xi0*xi0 + 4*a(5)*xi0*xi0*xi0 + else ! These expressions are mathematicaly equivalent but more accurate. + numerator = (a(1) - target_value) + xi0*(a(2) + xi0*(a(3) + xi0*(a(4) + a(5)*xi0))) + denominator = a(2) + xi0*(2.*a(3) + xi0*(3.*a(4) + 4.*a(5)*xi0)) + endif delta = -numerator / denominator @@ -463,7 +477,11 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & if ( xi0 > 1.0 ) then xi0 = 1.0 - grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) + if (use_2018_answers) then + grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) + else ! These expressions are mathematicaly equivalent but more accurate. + grad = a(2) + (2.*a(3) + (3.*a(4) + 4.*a(5))) + endif if ( grad == 0.0 ) xi0 = xi0 - eps endif From aac71f58c53c186fad7a0937841ffea1141010ca Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 2 Dec 2019 18:59:26 +0000 Subject: [PATCH 240/259] Fix units for terms used in advection of MEKE - Code was passing dimensional testing because a conversion factor was included to obtain the right units for the advective flux terms. The origin of the unit problem was in the rate of inter-column exchange (baroHu and baroHv) which were in units of [H L2] and should have been in units of [R Z L2]: - [H L2 ~> m3 or kg] so differs between Boussinesq and non-Boussinesq; - [R Z L2 ~> kg] for both modes. - This commit moves the conversion to the summation for the barotropic exchange, removes the previous scaling factors, and updates the relevant comments. - Closes #1036 --- src/parameterizations/lateral/MOM_MEKE.F90 | 35 ++++++++++------------ 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 9513937c9d..9f99017882 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -131,17 +131,17 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h tmp ! Temporary variable for diagnostic computation real, dimension(SZIB_(G),SZJ_(G)) :: & - MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with different units in different - ! places of [L2 T-2 ~> m2 s-2] or [m L4 T-3 ~> m5 s-3] or [kg m-2 L4 T-3 ~> kg m-2 s-3]. + MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m-2 s-3]. + ! In one place, MEKE_uflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_u, & ! The zonal diffusivity that is actually used [L2 T-1 ~> m2 s-1]. - baroHu, & ! Depth integrated accumulated zonal mass flux [H L2 ~> m3 or kg]. + baroHu, & ! Depth integrated accumulated zonal mass flux [R Z L2 ~> kg]. drag_vel_u ! A (vertical) viscosity associated with bottom drag at ! u-points [Z T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & - MEKE_vflux, & ! The meridional advective and diffusive flux of MEKE with different units in different - ! places of [L2 T-2 ~> m2 s-2] or [m L4 T-3 ~> m5 s-3] or [kg m-2 L4 T-3 ~> kg m-2 s-3]. + MEKE_vflux, & ! The meridional advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m-2 s-3]. + ! In one place, MEKE_vflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. - baroHv, & ! Depth integrated accumulated meridional mass flux [H L2 ~> m3 or kg]. + baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. drag_vel_v ! A (vertical) viscosity associated with bottom drag at ! v-points [Z T-1 ~> m s-1]. real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] @@ -149,8 +149,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Inv_K4_max ! The inverse of the local horizontal biharmonic viscosity [T L-4 ~> s m-4] real :: cdrag2 - real :: advFac ! The product of the advection scaling factor and some unit conversion - ! factors divided by the timestep [m H-1 T-1 ~> s-1 or m3 kg-1 s-1] + real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. real :: Rho0 ! A density used to convert mass to distance [R ~> kg m-3]. @@ -201,14 +200,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! advisable to use Strang splitting between the damping and diffusion. sdt_damp = sdt ; if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.) sdt_damp = 0.5*sdt - ! Calculate depth integrated mass flux if doing advection + ! Calculate depth integrated mass exchange if doing advection [R Z L2 ~> kg] if (CS%MEKE_advection_factor>0.) then do j=js,je ; do I=is-1,ie baroHu(I,j) = 0. enddo ; enddo do k=1,nz do j=js,je ; do I=is-1,ie - baroHu(I,j) = hu(I,j,k) + baroHu(I,j) = hu(I,j,k) * GV%H_to_RZ enddo ; enddo enddo do J=js-1,je ; do i=is,ie @@ -216,7 +215,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo do k=1,nz do J=js-1,je ; do i=is,ie - baroHv(i,J) = hv(i,J,k) + baroHv(i,J) = hv(i,J,k) * GV%H_to_RZ enddo ; enddo enddo endif @@ -358,7 +357,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculate Laplacian of MEKE !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-2,ie+1 - ! Here the units of MEKE_uflux are [L2 T-2 ~> m2 s-2]. + ! MEKE_uflux is used here as workspace with units of [L2 T-2 ~> m2 s-2]. MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%mask2dCu(I,j)) * & (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) ! This would have units of [R Z L2 T-2 ~> kg s-2] @@ -368,7 +367,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo !$OMP parallel do default(shared) do J=js-2,je+1 ; do i=is-1,ie+1 - ! Here the units of MEKE_vflux are [L2 T-2 ~> m2 s-2]. + ! MEKE_vflux is used here as workspace with units of [L2 T-2 ~> m2 s-2]. MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%mask2dCv(i,J)) * & (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) ! This would have units of [R Z L2 T-2 ~> kg s-2] @@ -457,12 +456,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h (MEKE%MEKE(i,j) - MEKE%MEKE(i,j+1)) enddo ; enddo if (CS%MEKE_advection_factor>0.) then - !### I think that for dimensional consistency, this should be: - ! advFac = GV%H_to_RZ * CS%MEKE_advection_factor / sdt - advFac = US%kg_m3_to_R*GV%H_to_Z * CS%MEKE_advection_factor / dt + advFac = CS%MEKE_advection_factor / sdt ! [T-1] !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - ! Here the units of the quantities added to MEKE_uflux and MEKE_vflux are [m L4 T-3]. + ! Here the units of the quantities added to MEKE_uflux are [R Z L4 T-3 ~> kg m2 s-3]. if (baroHu(I,j)>0.) then MEKE_uflux(I,j) = MEKE_uflux(I,j) + baroHu(I,j)*MEKE%MEKE(i,j)*advFac elseif (baroHu(I,j)<0.) then @@ -471,7 +468,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - ! Here the units of the quantities added to MEKE_uflux and MEKE_vflux are [m L4 T-3]. + ! Here the units of the quantities added to MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. if (baroHv(i,J)>0.) then MEKE_vflux(i,J) = MEKE_vflux(i,J) + baroHv(i,J)*MEKE%MEKE(i,j)*advFac elseif (baroHv(i,J)<0.) then @@ -480,10 +477,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo endif - !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - ! This expression is correct if the units of MEKE_uflux and MEKE_vflux are [kg m-2 L4 T-3]. MEKE%MEKE(i,j) = MEKE%MEKE(i,j) + (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) From b7b7fbce954f5541cfd568811e6686b469c2032a Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 27 Nov 2019 21:19:16 +0000 Subject: [PATCH 241/259] Removed out-of-date commented code - Removed commented code snippet that was out-of-date w.r.t. to the current code and completely misleading. --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 9f99017882..5632f63956 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -380,8 +380,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js-1,je+1 ; do i=is-1,ie+1 del2MEKE(i,j) = G%IareaT(i,j) * & ((MEKE_uflux(I,j) - MEKE_uflux(I-1,j)) + (MEKE_vflux(i,J) - MEKE_vflux(i,J-1))) - ! del2MEKE(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & - ! ((MEKE_uflux(I,j) - MEKE_uflux(I-1,j)) + (MEKE_vflux(i,J) - MEKE_vflux(i,J-1))) enddo ; enddo ! Bi-harmonic diffusion of MEKE From 9c4d22d236838460634a686719fe630f425b3f2e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 27 Nov 2019 21:21:54 +0000 Subject: [PATCH 242/259] Updated/added comments for units of variables in MOM_MEKE.F90 - Cleaned up/added comments annotating units. --- src/parameterizations/lateral/MOM_MEKE.F90 | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 5632f63956..eed783db98 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -265,7 +265,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo do i=is-1,ie+1 I_mass(i,j) = 0.0 - if (mass(i,j) > 0.0) I_mass(i,j) = 1.0 / mass(i,j) + if (mass(i,j) > 0.0) I_mass(i,j) = 1.0 / mass(i,j) ! [m2 kg-1] enddo enddo @@ -354,7 +354,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif if (CS%MEKE_K4 >= 0.0) then - ! Calculate Laplacian of MEKE + ! Calculate Laplacian of MEKE using MEKE_uflux and MEKE_vflux as temporary work space. !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-2,ie+1 ! MEKE_uflux is used here as workspace with units of [L2 T-2 ~> m2 s-2]. @@ -377,7 +377,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 + do j=js-1,je+1 ; do i=is-1,ie+1 ! del2MEKE has units [T-2 ~> s-2]. del2MEKE(i,j) = G%IareaT(i,j) * & ((MEKE_uflux(I,j) - MEKE_uflux(I-1,j)) + (MEKE_vflux(i,J) - MEKE_vflux(i,J-1))) enddo ; enddo @@ -385,7 +385,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Bi-harmonic diffusion of MEKE !$OMP parallel do default(shared) private(K4_here,Inv_K4_max) do j=js,je ; do I=is-1,ie - K4_here = CS%MEKE_K4 + K4_here = CS%MEKE_K4 ! [L4 T-1 ~> m4 s-1] ! Limit Kh to avoid CFL violations. Inv_K4_max = 64.0 * sdt * ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & max(G%IareaT(i,j), G%IareaT(i+1,j)))**2 @@ -398,15 +398,16 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo !$OMP parallel do default(shared) private(K4_here,Inv_K4_max) do J=js-1,je ; do i=is,ie - K4_here = CS%MEKE_K4 + K4_here = CS%MEKE_K4 ! [L4 T-1 ~> m4 s-1] Inv_K4_max = 64.0 * sdt * ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * max(G%IareaT(i,j), G%IareaT(i,j+1)))**2 if (K4_here*Inv_K4_max > 0.3) K4_here = 0.3 / Inv_K4_max + ! Here the units of MEKE_vflux are [kg m-2 L4 T-3]. MEKE_vflux(i,J) = ((K4_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & (del2MEKE(i,j+1) - del2MEKE(i,j)) enddo ; enddo - ! Store tendency arising from the bi-harmonic in del4MEKE + ! Store change in MEKE arising from the bi-harmonic in del4MEKE [L2 T-2]. !$OMP parallel do default(shared) do j=js,je ; do i=is,ie del4MEKE(i,j) = (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & @@ -415,7 +416,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo endif ! - if (CS%kh_flux_enabled) then ! Lateral diffusion of MEKE Kh_here = max(0., CS%MEKE_Kh) @@ -570,10 +570,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! Offer fields for averaging. - if (any([CS%id_Ue, CS%id_Ub, CS%id_Ut] > 0)) & tmp(:,:) = 0. - if (CS%id_MEKE>0) call post_data(CS%id_MEKE, MEKE%MEKE, CS%diag) if (CS%id_Ue>0) then do j=js,je ; do i=is,ie From 7dca672155a988876ab13a82680a44460ae848ae Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 2 Dec 2019 14:51:21 -0500 Subject: [PATCH 243/259] Corrected the formatting of a doxygen comment --- src/ALE/regrid_edge_values.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 4de17c88b4..f82e42e0e6 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -661,7 +661,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_val !!< Returned edge values [A]; the second index size is 2. + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. From 285273ac7a2758fe54913e69f0813fb863da48c6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 2 Dec 2019 20:17:57 +0000 Subject: [PATCH 244/259] Corrected/added converted MKS units in comments --- src/parameterizations/lateral/MOM_MEKE.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index eed783db98..5e15b66ab6 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -261,11 +261,11 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js-1,je+1 do i=is-1,ie+1 ; mass(i,j) = 0.0 ; enddo do k=1,nz ; do i=is-1,ie+1 - mass(i,j) = mass(i,j) + G%mask2dT(i,j) * (GV%H_to_RZ * h(i,j,k)) + mass(i,j) = mass(i,j) + G%mask2dT(i,j) * (GV%H_to_RZ * h(i,j,k)) ! [R Z ~> kg m-2] enddo ; enddo do i=is-1,ie+1 I_mass(i,j) = 0.0 - if (mass(i,j) > 0.0) I_mass(i,j) = 1.0 / mass(i,j) ! [m2 kg-1] + if (mass(i,j) > 0.0) I_mass(i,j) = 1.0 / mass(i,j) ! [R-1 Z-1 ~> m2 kg-1] enddo enddo @@ -402,12 +402,12 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h Inv_K4_max = 64.0 * sdt * ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * max(G%IareaT(i,j), G%IareaT(i,j+1)))**2 if (K4_here*Inv_K4_max > 0.3) K4_here = 0.3 / Inv_K4_max - ! Here the units of MEKE_vflux are [kg m-2 L4 T-3]. + ! Here the units of MEKE_vflux are [R Z L4 T-3]. MEKE_vflux(i,J) = ((K4_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & (del2MEKE(i,j+1) - del2MEKE(i,j)) enddo ; enddo - ! Store change in MEKE arising from the bi-harmonic in del4MEKE [L2 T-2]. + ! Store change in MEKE arising from the bi-harmonic in del4MEKE [L2 T-2 ~> m2 s-2]. !$OMP parallel do default(shared) do j=js,je ; do i=is,ie del4MEKE(i,j) = (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & @@ -454,7 +454,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h (MEKE%MEKE(i,j) - MEKE%MEKE(i,j+1)) enddo ; enddo if (CS%MEKE_advection_factor>0.) then - advFac = CS%MEKE_advection_factor / sdt ! [T-1] + advFac = CS%MEKE_advection_factor / sdt ! [T-1 ~> s-1] !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ! Here the units of the quantities added to MEKE_uflux are [R Z L4 T-3 ~> kg m2 s-3]. From 7a404fe27321bbff7d3253dbdd67722b2a9773e9 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 2 Dec 2019 21:17:06 +0000 Subject: [PATCH 245/259] Added more converted MKS units in comments --- src/parameterizations/lateral/MOM_MEKE.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 5e15b66ab6..38bf24ee60 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -391,7 +391,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h max(G%IareaT(i,j), G%IareaT(i+1,j)))**2 if (K4_here*Inv_K4_max > 0.3) K4_here = 0.3 / Inv_K4_max - ! Here the units of MEKE_uflux are [R Z L4 T-3]. + ! Here the units of MEKE_uflux are [R Z L4 T-3 ~> kg m2 s-3]. MEKE_uflux(I,j) = ((K4_here * (G%dy_Cu(I,j)*G%IdxCu(I,j))) * & ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & (del2MEKE(i+1,j) - del2MEKE(i,j)) @@ -402,7 +402,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h Inv_K4_max = 64.0 * sdt * ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * max(G%IareaT(i,j), G%IareaT(i,j+1)))**2 if (K4_here*Inv_K4_max > 0.3) K4_here = 0.3 / Inv_K4_max - ! Here the units of MEKE_vflux are [R Z L4 T-3]. + ! Here the units of MEKE_vflux are [R Z L4 T-3 ~> kg m2 s-3]. MEKE_vflux(i,J) = ((K4_here * (G%dx_Cv(i,J)*G%IdyCv(i,J))) * & ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & (del2MEKE(i,j+1) - del2MEKE(i,j)) From bb3827e37060d9879de06412c702c84372d6e972 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Dec 2019 15:08:53 -0500 Subject: [PATCH 246/259] Added conversion factors to forcing diagnostics Added conversion factors to 4 mass-flux diagnostics and comments to 4 others on why no conversion factors are needed. All answers are bitwise identical. --- src/core/MOM_forcing_type.F90 | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 05f2cac00a..9794070f20 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1284,20 +1284,22 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, ! surface mass flux maps handles%id_prcme = register_diag_field('ocean_model', 'PRCmE', diag%axesT1, Time, & - 'Net surface water flux (precip+melt+lrunoff+ice calving-evap)', 'kg m-2 s-1',& + 'Net surface water flux (precip+melt+lrunoff+ice calving-evap)', 'kg m-2 s-1', & standard_name='water_flux_into_sea_water', cmor_field_name='wfo', & cmor_standard_name='water_flux_into_sea_water',cmor_long_name='Water Flux Into Sea Water') + ! This diagnostic is rescaled to MKS units when combined. - handles%id_evap = register_diag_field('ocean_model', 'evap', diag%axesT1, Time, & - 'Evaporation/condensation at ocean surface (evaporation is negative)', 'kg m-2 s-1',& - standard_name='water_evaporation_flux', cmor_field_name='evs', & - cmor_standard_name='water_evaporation_flux', & + handles%id_evap = register_diag_field('ocean_model', 'evap', diag%axesT1, Time, & + 'Evaporation/condensation at ocean surface (evaporation is negative)', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + standard_name='water_evaporation_flux', cmor_field_name='evs', & + cmor_standard_name='water_evaporation_flux', & cmor_long_name='Water Evaporation Flux Where Ice Free Ocean over Sea') ! smg: seaice_melt field requires updates to the sea ice model handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & - 'kg m-2 s-1', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & cmor_field_name='fsitherm', & cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& @@ -1305,6 +1307,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_precip = register_diag_field('ocean_model', 'precip', diag%axesT1, Time, & 'Liquid + frozen precipitation into ocean', 'kg m-2 s-1') + ! This diagnostic is rescaled to MKS units when combined. handles%id_fprec = register_diag_field('ocean_model', 'fprec', diag%axesT1, Time, & 'Frozen precipitation into ocean', & @@ -1324,32 +1327,39 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) handles%id_frunoff = register_diag_field('ocean_model', 'frunoff', diag%axesT1, Time, & - 'Frozen runoff (calving) and iceberg melt into ocean', 'kg m-2 s-1', & + 'Frozen runoff (calving) and iceberg melt into ocean', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='water_flux_into_sea_water_from_icebergs', & cmor_field_name='ficeberg', & cmor_standard_name='water_flux_into_sea_water_from_icebergs', & cmor_long_name='Water Flux into Seawater from Icebergs') handles%id_lrunoff = register_diag_field('ocean_model', 'lrunoff', diag%axesT1, Time, & - 'Liquid runoff (rivers) into ocean', 'kg m-2 s-1', & + 'Liquid runoff (rivers) into ocean', & + units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & standard_name='water_flux_into_sea_water_from_rivers', cmor_field_name='friver', & cmor_standard_name='water_flux_into_sea_water_from_rivers', & cmor_long_name='Water Flux into Sea Water From Rivers') handles%id_net_massout = register_diag_field('ocean_model', 'net_massout', diag%axesT1, Time, & 'Net mass leaving the ocean due to evaporation, seaice formation', 'kg m-2 s-1') + ! This diagnostic is rescaled to MKS units when combined. handles%id_net_massin = register_diag_field('ocean_model', 'net_massin', diag%axesT1, Time, & 'Net mass entering ocean due to precip, runoff, ice melt', 'kg m-2 s-1') + ! This diagnostic is rescaled to MKS units when combined. handles%id_massout_flux = register_diag_field('ocean_model', 'massout_flux', diag%axesT1, Time, & 'Net mass flux of freshwater out of the ocean (used in the boundary flux calculation)', & 'kg m-2', conversion=diag%GV%H_to_kg_m2) + ! This diagnostic is calculated in MKS units. handles%id_massin_flux = register_diag_field('ocean_model', 'massin_flux', diag%axesT1, Time, & 'Net mass flux of freshwater into the ocean (used in boundary flux calculation)', 'kg m-2') + ! This diagnostic is calculated in MKS units. + !========================================================================= - ! area integrated surface mass transport + ! area integrated surface mass transport, all are rescaled to MKS units before area integration. handles%id_total_prcme = register_scalar_field('ocean_model', 'total_PRCmE', Time, diag, & long_name='Area integrated net surface water flux (precip+melt+liq runoff+ice calving-evap)',& From 3d7456a3e1d2b9e8f28668fb0d17d2392b7360fa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Dec 2019 15:11:14 -0500 Subject: [PATCH 247/259] Added correct scaling factors to chksum calls Added scale arguments to 5 chksum calls and grouped another two chksum calls while also adding the right scaling argument. All answers are bitwise identical. --- src/core/MOM.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 6 +++--- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ad9e235b27..4b16730fee 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1180,7 +1180,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_thermo) if (.not.CS%adiabatic) then if (CS%debug) then - call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2) + call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) 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, & haloshift=0, scale=GV%H_to_m*US%L_to_m**2) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index c479550847..8c016b11b0 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -480,7 +480,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call disable_averaging(CS%diag) if (CS%debug) then - call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym) + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) @@ -670,7 +670,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_m) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) call check_redundant("Predictor up ", up, vp, G) @@ -860,7 +860,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) if (CS%debug) then - call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym, vel_scale=1.0) + call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_m) ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 38bf24ee60..a2257369a8 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -188,7 +188,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) if (associated(MEKE%MEKE)) call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T) - call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m) + call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m*US%L_to_m**2) endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index b4c100dc5d..eb1afb6bb8 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -3,6 +3,7 @@ module MOM_set_diffusivity ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_checksums, only : hchksum_pair use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type @@ -344,8 +345,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%useKappaShear) then if (CS%debug) then - call hchksum(u_h, "before calc_KS u_h",G%HI) - call hchksum(v_h, "before calc_KS v_h",G%HI) + call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, scale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then From 6ab1721bd96aefea4b5b056d6852964996984865 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Dec 2019 15:18:45 -0500 Subject: [PATCH 248/259] +Unscales area before taking global sum Undoes the dimensional scaling of the cell areas before taking their global sum, so that the reproducing sum does not overflow when there is dimensional rescaling. All answers are bitwise identical when there is no rescaling, but this eliminates a source of inadvertent overflows or underflows in the global sums, and there is a new optional argument to compute_global_grid_integrals. --- src/framework/MOM_spatial_means.F90 | 2 +- src/initialization/MOM_fixed_initialization.F90 | 2 +- src/initialization/MOM_shared_initialization.F90 | 10 +++++++--- src/initialization/MOM_state_initialization.F90 | 7 +++++-- 4 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 829afb851f..16987087fa 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -43,7 +43,7 @@ function global_area_mean(var, G, scale) do j=js,je ; do i=is,ie tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo - global_area_mean = reproducing_sum(tmpForSumming) * (G%US%m_to_L**2 * G%IareaT_global) + global_area_mean = reproducing_sum(tmpForSumming) * G%IareaT_global end function global_area_mean diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 8ed9a0a4c7..0ddca45c51 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -159,7 +159,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) call initialize_grid_rotation_angle(G, PF) ! Compute global integrals of grid values for later use in scalar diagnostics ! - call compute_global_grid_integrals(G) + call compute_global_grid_integrals(G, US=US) ! Write out all of the grid data used by this run. if (write_geom) call write_ocean_geometry_file(G, PF, output_dir, US=US) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 3d0fe6f1ed..3338f1fedb 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1145,17 +1145,21 @@ end subroutine set_velocity_depth_min ! ----------------------------------------------------------------------------- !> Pre-compute global integrals of grid quantities (like masked ocean area) for !! later use in reporting diagnostics -subroutine compute_global_grid_integrals(G) - type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid +subroutine compute_global_grid_integrals(G, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming + real :: area_scale ! A scaling factor for area into MKS units integer :: i,j + area_scale = 1.0 ; if (present(US)) area_scale = US%L_to_m**2 + tmpForSumming(:,:) = 0. G%areaT_global = 0.0 ; G%IareaT_global = 0.0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - tmpForSumming(i,j) = G%areaT(i,j) * G%mask2dT(i,j) + tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo G%areaT_global = reproducing_sum(tmpForSumming) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 03310d70f3..ff08912191 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1889,16 +1889,19 @@ end subroutine set_velocity_depth_max !> Subroutine to pre-compute global integrals of grid quantities for !! later use in reporting diagnostics -subroutine compute_global_grid_integrals(G) +subroutine compute_global_grid_integrals(G, US) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming + real :: area_scale integer :: i,j + area_scale = US%L_to_m**2 tmpForSumming(:,:) = 0. G%areaT_global = 0.0 ; G%IareaT_global = 0.0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - tmpForSumming(i,j) = G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) + tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo G%areaT_global = reproducing_sum(tmpForSumming) G%IareaT_global = 1. / (G%areaT_global) From babc30a98c08f0c21aee02ed2228c45ac100d1ab Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Dec 2019 15:24:10 -0500 Subject: [PATCH 249/259] (*)Correct dimensionally inconsistent advective CFL Corrects the dimensionally inconsistent expressions for the CFL number in the tracer advection code, in which a negligible thickness had been added to the cell volume to avoid division by zero. This change does not alter the solutions in the MOM6-examples test cases, but now it permits dimensional rescaling of lengths over a much larger range, and it could change answers if the minimum layer thicknesses are small enough. --- src/tracer/MOM_tracer_advect.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e050933dc2..e425629c77 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -485,8 +485,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 + uhh(I)/(hprev(i+1,j,k)+h_neglect)) - CFL(I) = - uhh(I)/(hprev(i+1,j,k)+h_neglect) ! CFL is positive + !ts2(I) = 0.5*(1.0 + uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j))) + CFL(I) = - uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h hlos = MAX(0.0,-uhr(I-1,j,k)) @@ -497,8 +497,8 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect)) - CFL(I) = uhh(I)/(hprev(i,j,k)+h_neglect) ! CFL is positive + !ts2(I) = 0.5*(1.0 - uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) + CFL(I) = uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive endif enddo @@ -573,7 +573,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Original implementation of PLM !flux_x(I,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect)) + !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo endif ! usePPM @@ -856,8 +856,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k)+h_neglect)) - CFL(i) = - vhh(i,J) / (hprev(i,j+1,k)+h_neglect) ! CFL is positive + !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) + CFL(i) = - vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h hlos = MAX(0.0,-vhr(i,J-1,k)) @@ -868,8 +868,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k)+h_neglect)) - CFL(i) = vhh(i,J) / (hprev(i,j,k)+h_neglect) ! CFL is positive + !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) + CFL(i) = vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive endif enddo From e0d7236867ba67a5e9c6d2ed7e0085cf77882d48 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Dec 2019 18:46:55 -0500 Subject: [PATCH 250/259] Unscale sea level before averaging Unscale interface heights before taking a global average via a reproducing sum in non-Boussinesq mode global diagnostics to permit dimensional consistency testing over a larger range. All answers are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index f99b6d7f7c..668f185152 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -534,9 +534,10 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ call find_eta(h, tv, G, GV, US, eta) do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = (eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) + tmp1(i,j,k) = US%Z_to_m*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo - vol_tot = US%Z_to_m*reproducing_sum(tmp1, sums=vol_lay) + vol_tot = reproducing_sum(tmp1, sums=vol_lay) + do k=1,nz ; vol_lay(k) = US%m_to_Z * vol_lay(k) ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = H_to_kg_m2 * h(i,j,k) * areaTm(i,j) From 5a8f17e6687dc8db2cae7265a4e1cc9e0df7ca4b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Dec 2019 18:48:19 -0500 Subject: [PATCH 251/259] +Added an optional tmp_scale arg to global_i_mean Added an optional tmp_scale argument to global_i_mean and global_j_mean to specify an internal rescaling of variables being averaged before the reproducing sum. All answers are bitwise identical, but there are new optional arguments to two public interfaces. --- src/framework/MOM_spatial_means.F90 | 30 +++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 16987087fa..85d5ce452b 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -182,17 +182,20 @@ end function global_mass_integral !> Determine the global mean of a field along rows of constant i, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_i_mean(array, i_mean, G, mask, scale) +subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the i-mean - real, optional, intent(in) :: scale !< A rescaling factor for the variable + optional, intent(in) :: mask !< An array used for weighting the i-mean + real, optional, intent(in) :: scale !< A rescaling factor for the output variable + real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal + !! calculations that is removed from the output ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum real :: scalefac ! A scaling factor for the variable. + real :: unscale ! A factor for undoing any internal rescaling before output. real :: mask_sum_r integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -201,6 +204,10 @@ subroutine global_i_mean(array, i_mean, G, mask, scale) idg_off = G%idg_offset ; jdg_off = G%jdg_offset scalefac = 1.0 ; if (present(scale)) scalefac = scale + unscale = 1.0 + if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then + scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + endif ; endif call reset_EFP_overflow_error() allocate(asum(G%jsg:G%jeg)) @@ -253,24 +260,29 @@ subroutine global_i_mean(array, i_mean, G, mask, scale) enddo endif + if (unscale /= 1.0) then ; do j=js,je ; i_mean(j) = unscale*i_mean(j) ; enddo ; endif + deallocate(asum) end subroutine global_i_mean !> Determine the global mean of a field along rows of constant j, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_j_mean(array, j_mean, G, mask, scale) +subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the j-mean - real, optional, intent(in) :: scale !< A rescaling factor for the variable + optional, intent(in) :: mask !< An array used for weighting the j-mean + real, optional, intent(in) :: scale !< A rescaling factor for the output variable + real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal + !! calculations that is removed from the output ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum real :: mask_sum_r real :: scalefac ! A scaling factor for the variable. + real :: unscale ! A factor for undoing any internal rescaling before output. integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -278,6 +290,10 @@ subroutine global_j_mean(array, j_mean, G, mask, scale) idg_off = G%idg_offset ; jdg_off = G%jdg_offset scalefac = 1.0 ; if (present(scale)) scalefac = scale + unscale = 1.0 + if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then + scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + endif ; endif call reset_EFP_overflow_error() allocate(asum(G%isg:G%ieg)) @@ -330,6 +346,8 @@ subroutine global_j_mean(array, j_mean, G, mask, scale) enddo endif + if (unscale /= 1.0) then ; do i=is,ie ; j_mean(i) = unscale*j_mean(i) ; enddo ; endif + deallocate(asum) end subroutine global_j_mean From 274a61315c85caac30ea63195fc1f3f75e168a8f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Dec 2019 18:48:46 -0500 Subject: [PATCH 252/259] Expand consistency testing with i-mean sponges Use tmp_scale when taking the i-mean interface heights for i-mean sponges, to give a greatly expanded range of dimensional consistency testing. All answers are bitwise identical. --- src/parameterizations/vertical/MOM_sponge.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index dd0887845c..6016dbb98b 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -420,7 +420,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) eta_anom(i,j) = e_D(i,j,k) - CS%Ref_eta_im(j,k) if (CS%Ref_eta_im(j,K) < -G%bathyT(i,j)) eta_anom(i,j) = 0.0 enddo ; enddo - call global_i_mean(eta_anom(:,:), eta_mean_anom(:,K), G) + call global_i_mean(eta_anom(:,:), eta_mean_anom(:,K), G, tmp_scale=US%Z_to_m) enddo if (CS%fldno > 0) allocate(fld_mean_anom(G%isd:G%ied,nz,CS%fldno)) From 0a3faa7ea521cdc2b8297d31409d14b2ea1124e6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 6 Dec 2019 11:04:36 -0500 Subject: [PATCH 253/259] +Simplified handling of time with forcing type Refactored how time-averaging of fluxes in forcing types that span multiple timesteps and flux diagnostics are handled, and rescaled the units of fluxes%dt_buoy_accum from [s] to [T]. This involved changing the arguments to fluxes_accumulate, forcing_accumulate, mech_forcing_diags and forcing_diagnostics, but because of the differing types of the arguments, an incompatible mix of code will not compile. Also changed the units of dt as passed to accumulate_net_input, and made a minor change to extractFluxes1d to avoid the possibilty of a division by zero. All answers are bitwise identical, but there are public interface changes, including changes that impact the mct and nuopc driver codes. --- .../MOM_surface_forcing_gfdl.F90 | 20 +++-- config_src/coupled_driver/ocean_model_MOM.F90 | 18 ++--- config_src/mct_driver/mom_ocean_model_mct.F90 | 19 ++--- .../mct_driver/mom_surface_forcing_mct.F90 | 20 +++-- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 18 ++--- .../mom_surface_forcing_nuopc.F90 | 22 +++--- config_src/solo_driver/MOM_driver.F90 | 19 +++-- src/core/MOM.F90 | 2 +- src/core/MOM_forcing_type.F90 | 74 ++++++++++--------- src/diagnostics/MOM_sum_output.F90 | 18 ++--- 10 files changed, 111 insertions(+), 119 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 08a09dbe23..9743c7fa3f 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -205,7 +205,7 @@ module MOM_surface_forcing_gfdl !> This subroutine translates the Ice_ocean_boundary_type into a MOM !! thermodynamic forcing type, including changes of units, sign conventions, !! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc_state) +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, US, CS, sfc_state) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -215,6 +215,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. + real, intent(in) :: valid_time !< The amount of time over which these fluxes + !! should be applied [s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -307,7 +309,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc if (CS%restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization @@ -324,11 +325,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie @@ -337,6 +333,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) endif ! endif for allocation and initialization + + ! Indicate that there are new unused fluxes. + fluxes%fluxes_used = .false. + fluxes%dt_buoy_accum = US%s_to_T*valid_time + + if (CS%allow_flux_adjustments) then + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 + endif + do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 9982754053..1f01845ae4 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -513,7 +513,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (do_thermo) then if (OS%fluxes%fluxes_used) then - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) ! Add ice shelf fluxes @@ -528,14 +528,11 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) ! Here weight=1, so just store the current fluxes call disable_averaging(OS%diag) #endif - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = dt_coupling else ! The previous fluxes have not been used yet, so translate the input fluxes ! into a temporary type and then accumulate them in about 20 lines. OS%flux_tmp%C_p = OS%fluxes%C_p - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) if (OS%use_ice_shelf) & @@ -544,7 +541,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) + call fluxes_accumulate(OS%flux_tmp, OS%fluxes, OS%grid, weight) #ifdef _USE_GENERIC_TRACER ! Incorporate the current tracer fluxes into the running averages call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) @@ -646,16 +643,11 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 if (do_dyn) then - call enable_averaging(dt_coupling, OS%Time_dyn, OS%diag) - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time_dyn, OS%diag, OS%forcing_CSp%handles) endif if (OS%fluxes%fluxes_used .and. do_thermo) then - 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%US, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) endif ! Translate state into Ocean. diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 240766a8d2..63556c2750 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -515,7 +515,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) if (do_thermo) & - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, & OS%restore_salinity, OS%restore_temp) @@ -543,16 +543,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = dt_coupling - else OS%flux_tmp%C_p = OS%fluxes%C_p if (do_thermo) & - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) if (OS%use_ice_shelf) then @@ -570,7 +566,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, dt_coupling, OS%grid, weight) + call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) ! Some of the fields that exist in both the forcing and mech_forcing types ! (e.g., ustar) are time-averages must be copied back to the forces type. @@ -669,15 +665,10 @@ 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(dt_coupling, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then - 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%US, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) endif ! Translate state into Ocean. diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index b487787a2e..981202eda8 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -192,7 +192,7 @@ module MOM_surface_forcing_mct !> This subroutine translates the Ice_ocean_boundary_type into a MOM !! thermodynamic forcing type, including changes of units, sign conventions, !! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, US, CS, & sfc_state, restore_salt, restore_temp) type(ice_ocean_boundary_type), & @@ -205,6 +205,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. + real, intent(in) :: valid_time !< The amount of time over which these fluxes + !! should be applied [s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -309,7 +311,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization @@ -326,11 +327,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie @@ -339,6 +335,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) endif ! endif for allocation and initialization + + ! Indicate that there are new unused fluxes. + fluxes%fluxes_used = .false. + fluxes%dt_buoy_accum = US%s_to_T*valid_time + + if (CS%allow_flux_adjustments) then + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 + endif + do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 1e13b8e536..240b576669 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -517,7 +517,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%fluxes%fluxes_used) then if (do_thermo) & - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, & OS%restore_salinity, OS%restore_temp) @@ -544,13 +544,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = dt_coupling else OS%flux_tmp%C_p = OS%fluxes%C_p if (do_thermo) & - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) if (OS%use_ice_shelf) then @@ -568,7 +565,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, dt_coupling, OS%grid, weight) + call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) ! Some of the fields that exist in both the forcing and mech_forcing types ! (e.g., ustar) are time-averages must be copied back to the forces type. call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) @@ -664,15 +661,10 @@ 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(dt_coupling, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then - 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, US%US, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) endif ! Translate state into Ocean. diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 955e608ac4..270d4e9f4c 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -199,7 +199,7 @@ module MOM_surface_forcing_nuopc !> This subroutine translates the Ice_ocean_boundary_type into a MOM !! thermodynamic forcing type, including changes of units, sign conventions, !! and putting the fields into arrays with MOM-standard halos. -subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, US, CS, & sfc_state, restore_salt, restore_temp) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive @@ -210,6 +210,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. + real, intent(in) :: valid_time !< The amount of time over which these fluxes + !! should be applied [s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -314,10 +316,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization - if (((associated(IOB%ustar_berg) .and. (.not.associated(fluxes%ustar_berg))) & .or. (associated(IOB%area_berg) .and. (.not.associated(fluxes%area_berg)))) & .or. (associated(IOB%mass_berg) .and. (.not.associated(fluxes%mass_berg)))) & @@ -331,12 +331,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) - - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie @@ -345,6 +339,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, & CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) endif ! endif for allocation and initialization + + ! Indicate that there are new unused fluxes. + fluxes%fluxes_used = .false. + fluxes%dt_buoy_accum = US%s_to_T*valid_time + + if (CS%allow_flux_adjustments) then + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 + endif + do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index a6d6597c0e..cea90b5db4 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -133,12 +133,15 @@ program MOM_main ! if Time_step_ocean is not an exact ! representation of dt_forcing. real :: dt_forcing ! The coupling time step [s]. - real :: dt ! The baroclinic dynamics time step [s]. + real :: dt ! The nominal baroclinic dynamics time step [s]. real :: dt_off ! Offline time step [s]. integer :: ntstep ! The number of baroclinic dynamics time steps ! within dt_forcing. - real :: dt_therm - real :: dt_dyn, dtdia, t_elapsed_seg + real :: dt_therm ! The thermodynamic timestep [s] + real :: dt_dyn ! The actual dynamic timestep used [s]. The value of dt_dyn is + ! chosen so that dt_forcing is an integer multiple of dt_dyn. + real :: dtdia ! The diabatic timestep [s] + real :: t_elapsed_seg ! The elapsed time in this run segment [s] integer :: n, n_max, nts, n_last_thermo logical :: diabatic_first, single_step_call type(time_type) :: Time2, time_chg @@ -491,7 +494,7 @@ program MOM_main call add_shelf_forces(grid, US, Ice_shelf_CSp, forces) endif fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = dt_forcing + fluxes%dt_buoy_accum = US%s_to_T*dt_forcing if (use_waves) then call Update_Surface_Waves(grid, GV, US, time, time_step_ocean, waves_csp) @@ -573,16 +576,12 @@ program MOM_main call write_cputime(Time, ns+ntstep-1, nmax, write_CPU_CSp) endif ; endif - call enable_averaging(dt_forcing, Time, diag) - call mech_forcing_diags(forces, dt_forcing, grid, diag, surface_forcing_CSp%handles) - call disable_averaging(diag) + call mech_forcing_diags(forces, dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) if (.not. offline_tracer_mode) then if (fluxes%fluxes_used) then - call enable_averaging(fluxes%dt_buoy_accum, Time, diag) - call forcing_diagnostics(fluxes, sfc_state, fluxes%dt_buoy_accum, grid, US, & + call forcing_diagnostics(fluxes, sfc_state, grid, US, Time, & diag, surface_forcing_CSp%handles) - 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.") diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4b16730fee..690e5250db 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -626,7 +626,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & elseif (thermo_does_span_coupling) then dtdia = dt_therm if ((fluxes%dt_buoy_accum > 0.0) .and. (dtdia > time_interval) .and. & - (abs(US%s_to_T*fluxes%dt_buoy_accum - dtdia) > 1e-6*dtdia)) then + (abs(fluxes%dt_buoy_accum - dtdia) > 1e-6*dtdia)) then call MOM_error(FATAL, "step_MOM: Mismatch between long thermodynamic "//& "timestep and time over which buoyancy fluxes have been accumulated.") endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9794070f20..3dd3af8fbf 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -7,6 +7,7 @@ module MOM_forcing_type use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled +use MOM_diag_mediator, only : enable_averages, enable_averaging, disable_averaging use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_EOS, only : calculate_density_derivs use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -161,7 +162,7 @@ module MOM_forcing_type logical :: fluxes_used = .true. !< If true, all of the heat, salt, and mass !! fluxes have been applied to the ocean. real :: dt_buoy_accum = -1.0 !< The amount of time over which the buoyancy fluxes - !! should be applied [s]. If negative, this forcing + !! should be applied [T ~> s]. If negative, this forcing !! type variable has not yet been inialized. real :: C_p !< heat capacity of seawater [J kg-1 degC-1]. @@ -410,7 +411,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW [degC H ~> degC m or degC kg m-2]. real :: pen_sw_tot_rate(SZI_(G)) ! Summed rate of shortwave heating across bands ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - real :: Ih_limit ! inverse depth at which surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] + real :: Ih_limit ! inverse depth at which surface fluxes start to be limited + ! or 0 for no limiting [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth real :: W_m2_to_H_T ! converts W/m^2 to H degC T-1 [degC H T-1 W-2 m2 ~> degC m3 J-1 or degC kg J-1] real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature @@ -438,7 +440,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & if (present(pen_sw_bnd_rate)) do_PSWBR = .true. !}BGR - Ih_limit = 1.0 / FluxRescaleDepth + Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth RZ_T_to_W_m2_degC = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T I_Cp = 1.0 / fluxes%C_p W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * fluxes%C_p) @@ -488,8 +490,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & do i=is,ie - scale = 1.0 - if (htot(i)*Ih_limit < 1.0) scale = htot(i)*Ih_limit + scale = 1.0 ; if ((Ih_limit > 0.0) .and. (htot(i)*Ih_limit < 1.0)) scale = htot(i)*Ih_limit ! Convert the penetrating shortwave forcing to (K * H) and reduce fluxes for shallow depths. ! (H=m for Bouss, H=kg/m2 for non-Bouss) @@ -1877,40 +1878,38 @@ end subroutine register_forcing_type_diags !> Accumulate the forcing over time steps, taking input from a mechanical forcing type !! and a temporary forcing-flux type. -subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) +subroutine forcing_accumulate(flux_tmp, forces, fluxes, G, wt2) type(forcing), intent(in) :: flux_tmp !< A temporary structure with current !!thermodynamic forcing fields type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged !! thermodynamic forcing fields - real, intent(in) :: dt !< The elapsed time since the last call to this subroutine [s] - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, intent(out) :: wt2 !< The relative weight of the new fluxes ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, ! and increments the amount of time over which the buoyancy forcing should be ! applied, all via a call to fluxes accumulate. - call fluxes_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) + call fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) end subroutine forcing_accumulate !> Accumulate the thermodynamic fluxes over time steps -subroutine fluxes_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) +subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) type(forcing), intent(in) :: flux_tmp !< A temporary structure with current - !! thermodynamic forcing fields + !! thermodynamic forcing fields type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged - !! thermodynamic forcing fields - real, intent(in) :: dt !< The elapsed time since the last call to this subroutine [s] - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + !! thermodynamic forcing fields + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, intent(out) :: wt2 !< The relative weight of the new fluxes type(mech_forcing), optional, intent(in) :: forces !< A structure with the driving mechanical forces ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, - ! and increments the amount of time over which the buoyancy forcing should be - ! applied. + ! and increments the amount of time over which the buoyancy forcing in fluxes should be + ! applied based on the time interval stored in flux_tmp. real :: wt1 integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -1921,13 +1920,13 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (fluxes%dt_buoy_accum < 0) call MOM_error(FATAL, "forcing_accumulate: "//& + if (fluxes%dt_buoy_accum < 0) call MOM_error(FATAL, "fluxes_accumulate: "//& "fluxes must be initialzed before it can be augmented.") ! wt1 is the relative weight of the previous fluxes. - wt1 = fluxes%dt_buoy_accum / (fluxes%dt_buoy_accum + dt) - wt2 = 1.0 - wt1 ! = dt / (fluxes%dt_buoy_accum + dt) - fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + dt + wt1 = fluxes%dt_buoy_accum / (fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum) + wt2 = 1.0 - wt1 ! = flux_tmp%dt_buoy_accum / (fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum) + fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum ! Copy over the pressure fields and accumulate averages of ustar, either from the forcing ! type or from the temporary fluxes type. @@ -2198,11 +2197,12 @@ end subroutine copy_back_forcing_fields !> Offer mechanical forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. -subroutine mech_forcing_diags(forces, dt, G, diag, handles) +subroutine mech_forcing_diags(forces, dt, G, time_end, diag, handles) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< time step + real, intent(in) :: dt !< time step for the forcing [s] type(ocean_grid_type), intent(in) :: G !< grid type - type(diag_ctrl), intent(in) :: diag !< diagnostic type + type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. + type(diag_ctrl), intent(inout) :: diag !< diagnostic type type(forcing_diags), intent(inout) :: handles !< diagnostic id for diag_manager integer :: i,j,is,ie,js,je @@ -2210,7 +2210,8 @@ subroutine mech_forcing_diags(forces, dt, G, diag, handles) call cpu_clock_begin(handles%id_clock_forcing) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (query_averaging_enabled(diag)) then + call enable_averaging(dt, time_end, diag) + ! if (query_averaging_enabled(diag)) then if ((handles%id_taux > 0) .and. associated(forces%taux)) & call post_data(handles%id_taux, forces%taux, diag) @@ -2224,22 +2225,23 @@ subroutine mech_forcing_diags(forces, dt, G, diag, handles) if ((handles%id_area_berg > 0) .and. associated(forces%area_berg)) & call post_data(handles%id_area_berg, forces%area_berg, diag) - endif + ! endif + call disable_averaging(diag) call cpu_clock_end(handles%id_clock_forcing) end subroutine mech_forcing_diags !> Offer buoyancy forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. -subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) +subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - real, intent(in) :: dt !< time step type(ocean_grid_type), intent(in) :: G !< grid type - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(diag_ctrl), intent(in) :: diag !< diagnostic regulator + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. + type(diag_ctrl), intent(inout) :: diag !< diagnostic regulator type(forcing_diags), intent(inout) :: handles !< diagnostic ids ! local @@ -2248,7 +2250,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) real :: ave_flux ! for diagnosing averaged boundary flux real :: C_p ! seawater heat capacity (J/(deg K * kg)) real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] - real :: I_dt ! inverse time step + real :: I_dt ! inverse time step [s-1] real :: ppt2mks ! conversion between ppt and mks integer :: i,j,is,ie,js,je @@ -2256,11 +2258,12 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) C_p = fluxes%C_p RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T - I_dt = 1.0/dt + I_dt = 1.0 / (US%T_to_s*fluxes%dt_buoy_accum) ppt2mks = 1e-3 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (query_averaging_enabled(diag)) then + call enable_averages(fluxes%dt_buoy_accum, time_end, diag) + ! if (query_averaging_enabled(diag)) then ! post the diagnostics for surface mass fluxes ================================== @@ -2796,7 +2799,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, US, diag, handles) if ((handles%id_ustar_ice_cover > 0) .and. associated(fluxes%ustar_shelf)) & call post_data(handles%id_ustar_ice_cover, fluxes%ustar_shelf, diag) - endif ! query_averaging_enabled + ! endif ! query_averaging_enabled + call disable_averaging(diag) call cpu_clock_end(handles%id_clock_forcing) end subroutine forcing_diagnostics diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 668f185152..6affbab231 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -944,7 +944,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) !! describe the surface state of the ocean. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. - real, intent(in) :: dt !< The amount of time over which to average [s]. + real, intent(in) :: dt !< The amount of time over which to average [T ~> s]. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call @@ -963,7 +963,6 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) real :: heat_input ! The total heat added by boundary fluxes, integrated ! over a time step and summed over space [J]. real :: C_p ! The heat capacity of seawater [J degC-1 kg-1]. - real :: dt_in_T ! Time increment [T ~> s] real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] type(EFP_type) :: & @@ -977,13 +976,12 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec C_p = fluxes%C_p RZL2_to_kg = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m - dt_in_T = US%s_to_T*dt FW_in(:,:) = 0.0 ; FW_input = 0.0 if (associated(fluxes%evap)) then if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie - FW_in(i,j) = RZL2_to_kg * dt_in_T*G%areaT(i,j)*(fluxes%evap(i,j) + & + FW_in(i,j) = RZL2_to_kg * dt*G%areaT(i,j)*(fluxes%evap(i,j) + & (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j)) + & (fluxes%fprec(i,j) + fluxes%frunoff(i,j)))) enddo ; enddo @@ -994,7 +992,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) endif if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie - FW_in(i,j) = FW_in(i,j) + RZL2_to_kg*dt_in_T * & + FW_in(i,j) = FW_in(i,j) + RZL2_to_kg*dt * & G%areaT(i,j) * fluxes%seaice_melt(i,j) enddo ; enddo ; endif @@ -1002,18 +1000,18 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (CS%use_temperature) then if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j) * (fluxes%sw(i,j) + & + heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j) * (fluxes%sw(i,j) + & (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j) * fluxes%seaice_melt_heat(i,j) + heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j) * fluxes%seaice_melt_heat(i,j) enddo ; enddo ; endif ! smg: new code ! include heat content from water transport across ocean surface ! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie -! heat_in(i,j) = heat_in(i,j) + dt_in_T*RZL2_to_kg*G%areaT(i,j) * & +! heat_in(i,j) = heat_in(i,j) + dt*RZL2_to_kg*G%areaT(i,j) * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) & ! + (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) & ! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & @@ -1043,7 +1041,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) heat_in(i,j) = heat_in(i,j) + US%L_to_m**2*G%areaT(i,j) * tv%frazil(i,j) enddo ; enddo ; endif if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%L_to_m**2*G%areaT(i,j)*fluxes%heat_added(i,j) + heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j)*fluxes%heat_added(i,j) enddo ; enddo ; endif ! if (associated(sfc_state%sw_lost)) then ; do j=js,je ; do i=is,ie ! heat_in(i,j) = heat_in(i,j) - US%L_to_m**2*G%areaT(i,j) * sfc_state%sw_lost(i,j) @@ -1051,7 +1049,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (associated(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie ! convert salt_flux from kg (salt)/(m^2 s) to ppt * [m s-1]. - salt_in(i,j) = RZL2_to_kg * dt_in_T * & + salt_in(i,j) = RZL2_to_kg * dt * & G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) enddo ; enddo ; endif endif From ef86e87b09430cc58ebe783886835d5253e5b5c5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 6 Dec 2019 13:02:30 -0500 Subject: [PATCH 254/259] +Added the new parameter KAPPA_SHEAR_ITER_BUG Added the new runtime parameters KAPPA_SHEAR_ITER_BUG and KD_TRUNC_KAPPA_SHEAR to permit correction of a dimensionally inconsistent expression in the Newton's method solver code of kappa_shear, and to allow the value of shear mixing that is neglected compared with the background mixing to be set at run-time instead of being hard-coded. By default, all answers are bitwise identical, but there are two new runtime parameters and the MOM_parameter_doc files change. --- .../vertical/MOM_kappa_shear.F90 | 60 ++++++++++++------- 1 file changed, 38 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index d315a18b16..9349cf06d7 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -34,10 +34,10 @@ module MOM_kappa_shear !> This control structure holds the parameters that regulate shear mixing type, public :: Kappa_shear_CS ; private real :: RiNo_crit !< The critical shear Richardson number for - !! shear-entrainment. The theoretical value is 0.25. + !! shear-entrainment [nondim]. The theoretical value is 0.25. !! The values found by Jackson et al. are 0.25-0.35. real :: Shearmix_rate !< A nondimensional rate scale for shear-driven - !! entrainment. The value given by Jackson et al. + !! entrainment [nondim]. The value given by Jackson et al. !! is 0.085-0.089. real :: FRi_curvature !< A constant giving the curvature of the function !! of the Richardson number that relates shear to @@ -50,15 +50,16 @@ module MOM_kappa_shear !! shear (i.e. proportional to |S|*tke) [nondim]. !! The values found by Jackson et al. are 0.14-0.12. real :: lambda !< The coefficient for the buoyancy length scale - !! in the kappa equation. Nondimensional. + !! in the kappa equation [nondim]. !! The values found by Jackson et al. are 0.82-0.81. real :: lambda2_N_S !< The square of the ratio of the coefficients of !! the buoyancy and shear scales in the diffusivity - !! equation, 0 to eliminate the shear scale. Nondim. + !! equation, 0 to eliminate the shear scale [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. real :: kappa_0 !< The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: kappa_tol_err !< The fractional error in kappa that is tolerated. - real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity. + real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. + real :: kappa_tol_err !< The fractional error in kappa that is tolerated [nondim]. + real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity [nondim]. integer :: nkml !< The number of layers in the mixed layer, as !! treated in this routine. If the pieces of the !! mixed layer are not to be treated collectively, @@ -67,6 +68,9 @@ module MOM_kappa_shear !! to estimate the instantaneous shear-driven mixing. integer :: max_KS_it !< The maximum number of iterations that may be used !! to estimate the time-averaged diffusivity. + logical :: dKdQ_iteration_bug !< If true. use an older, dimensionally inconsistent estimate of + !! the derivative of diffusivity with energy in the Newton's method + !! iteration. The bug causes undercorrections when dz > 1m. logical :: KS_at_vertex !< If true, do the calculations of the shear-driven mixing !! at the cell vertices (i.e., the vorticity points). logical :: eliminate_massless !< If true, massless layers are merged with neighboring @@ -734,7 +738,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & local_src_avg, & ! The time-integral of the local source [nondim]. tol_min, & ! Minimum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_max, & ! Maximum tolerated ksrc for the corrector step [T-1 ~> s-1]. - tol_chg, & ! The tolerated change integrated in time [nondim]. + tol_chg, & ! The tolerated kappa change integrated over a timestep [nondim]. dist_from_top, & ! The distance from the top surface [Z ~> m]. local_src ! The sum of all sources of kappa, including kappa_src and ! sources from the elliptic term [T-1 ~> s-1]. @@ -747,11 +751,14 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! [Pa Z-1 = kg m-1 s-2 Z-1 ~> kg m-2 s-2]. real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. - real :: tol_dksrc, tol2 ! ### Tolerances that need to be set better later. + real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration + ! relative to the local source [nondim]. + real :: tol2 ! The tolerance for the change in the kappa source within an iteration + ! relative to the average local source over previous iterations [nondim]. real :: tol_dksrc_low ! The tolerance for the fractional decrease in ksrc - ! within an iteration. 0 < tol_dksrc_low < 1. + ! within an iteration [nondim]. 0 < tol_dksrc_low < 1. real :: Ri_crit ! The critical shear Richardson number for shear- - ! driven mixing. The theoretical value is 0.25. + ! driven mixing [nondim]. The theoretical value is 0.25. real :: dt_rem ! The remaining time to advance the solution [T ~> s]. real :: dt_now ! The time step used in the current iteration [T ~> s]. real :: dt_wt ! The fractional weight of the current iteration [nondim]. @@ -794,7 +801,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & gR0 = GV%z_to_H*GV%H_to_Pa g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) k0dt = dt*CS%kappa_0 - ! These are hard-coded for now. Perhaps these could be made dynamic later? + !### These 3 tolerances are hard-coded and fixed 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 @@ -1464,7 +1471,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & TKE_min = max(CS%TKE_bg, 1.0E-20*US%m_to_Z**2*US%T_to_s**2) Ri_crit = CS%Rino_crit Ilambda2 = 1.0 / CS%lambda**2 - kappa_trunc = 0.01*kappa0 ! ### CHANGE THIS HARD-WIRING LATER? + kappa_trunc = CS%kappa_trunc do_Newton = .false. ; abort_Newton = .false. tol_err = CS%kappa_tol_err Newton_err = 0.2 ! This initial value may be automatically reduced later. @@ -1691,11 +1698,13 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & cK(K+1) = bK * Idz(k) cKcomp = bK * (Idz(k-1)*cKcomp + decay_term_k) ! = 1-cK(K+1) - !### The following expression appears to be dimensionally inconsistent in length. -RWH - dKdQ(K) = bK * (Idz(k-1)*dKdQ(K-1)*cQ(K) + & + if (CS%dKdQ_iteration_bug) then + dKdQ(K) = bK * (Idz(k-1)*dKdQ(K-1)*cQ(K) + & US%m_to_Z*(N2(K)*Ilambda2 + f2) * I_Q**2 * kappa(K) ) - ! I think that the second term needs to be multiplied by dz_Int(K): - ! dz_Int(K)*(N2(K)*Ilambda2 + f2) * I_Q**2 * kappa(K) ) + else + dKdQ(K) = bK * (Idz(k-1)*dKdQ(K-1)*cQ(K) + & + dz_Int(K)*(N2(K)*Ilambda2 + f2) * I_Q**2 * kappa(K) ) + endif dK(K) = bK * (kap_src + Idz(k-1)*dK(K-1) + Idz(k-1)*dKdQ(K-1)*dQ(K-1)) ! Truncate away negligibly small values of kappa. @@ -1822,11 +1831,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & kap_src = dz_Int(K) * (K_src(K) - I_Ld2(K)*kappa_prev(K)) + & (Idz(k-1)*(kappa_prev(k-1)-kappa_prev(k)) - & Idz(k)*(kappa_prev(k)-kappa_prev(k+1))) - !### The last line of the following appears to be dimensionally inconsistent with the first two. - ! I think that the term on the last line needs to be multiplied by dz_Int(K). K_err_lin = -Idz(k-1)*(dK(K-1)-dK(K)) + Idz(k)*(dK(K)-dK(K+1)) + & dz_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & - US%m_to_Z*(N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) + dz_Int(K)*(N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) tke_src = dz_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*TKE_decay(K)) - & @@ -1950,8 +1957,9 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + real :: kappa_0_unscaled ! The value of kappa_0 in MKS units [m2 s-1] real :: KD_normal ! The KD of the main model, read here only as a parameter - ! for setting the default of KD_SMOOTH + ! for setting the default of KD_SMOOTH in MKS units [m2 s-1] if (associated(CS)) then call MOM_error(WARNING, "kappa_shear_init called with an associated "// & @@ -1995,7 +2003,11 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& "diffusivities. Defaults to value of KD.", & - units="m2 s-1", default=KD_normal, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=KD_normal, scale=US%m2_s_to_Z2_T, unscaled=kappa_0_unscaled) + call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & + "The value of shear-driven diffusivity that is considered negligible "//& + "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & + units="m2 s-1", default=0.01*kappa_0_unscaled, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & "The nondimensional curvature of the function of the "//& "Richardson number in the kappa source term in the "//& @@ -2050,12 +2062,16 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "components are set to 0. A reasonable value might be "//& "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & "If true, write debugging data for the kappa-shear code. \n"//& "Caution: this option is _very_ verbose and should only "//& "be used in single-column mode!", & default=.false., debuggingParam=.true.) - + call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & + "If true. use an older, dimensionally inconsistent estimate of the "//& + "derivative of diffusivity with energy in the Newton's method iteration. "//& + "The bug causes undercorrections when dz > 1m.", default=.true.) ! id_clock_KQ = cpu_clock_id('Ocean KS kappa_shear', grain=CLOCK_ROUTINE) ! id_clock_avg = cpu_clock_id('Ocean KS avg', grain=CLOCK_ROUTINE) ! id_clock_project = cpu_clock_id('Ocean KS project', grain=CLOCK_ROUTINE) From 5ad6a38fe8adb7627dd60c52bbbca3672d4dd005 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 10 Dec 2019 11:11:25 -0500 Subject: [PATCH 255/259] +(*)Add the new parameter VERT_FRICTION_2018_ANSWERS Added the new runtime parameter VERT_FRICTION_2018_ANSWERS that avoids the use of the hard-coded maximum viscous mixing length per timestep in the vertical viscosity code, and added h_neglect in the denominators of several terms in the viscosity code. All answers in the MOM6-examples test cases are bitwise identical, but the answers will change if ANGSTROM is set to 0, and there is a new entry in the MOM_parameter_doc files. --- .../vertical/MOM_vert_friction.F90 | 59 ++++++++++++------- 1 file changed, 38 insertions(+), 21 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c612a1ceed..a6a23d2adf 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -100,6 +100,10 @@ module MOM_vert_friction !! calculation, perhaps based on a bulk Richardson !! number criterion, to determine the mixed layer !! thickness for viscosity. + logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the + !! answers from the end of 2018. Otherwise, use expressions that do not + !! use an arbitary and hard-coded maximum viscous coupling coefficient + !! between layers. logical :: debug !< If true, write verbose checksums for debugging purposes. integer :: nkml !< The number of layers in the mixed layer. integer, pointer :: ntrunc !< The number of times the velocity has been @@ -363,7 +367,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & zDS = 0.0 stress = dt_Rho0 * forces%tauy(i,J) do k=1,nz - h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_neglect hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a v(i,J,k) = v(i,J,k) + I_Hmix * hfr * stress zDS = zDS + h_a ; if (zDS >= Hmix) exit @@ -678,8 +682,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (CS%bottomdraglaw) then ; do I=Isq,Ieq kv_bbl(I) = visc%Kv_bbl_u(I,j) - bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H - if (do_i(I)) I_Hbbl(I) = 1.0 / (bbl_thick(I) + h_neglect) + bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H + h_neglect + if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) enddo ; endif do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then @@ -845,7 +849,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (CS%bottomdraglaw) then ; do i=is,ie kv_bbl(i) = visc%Kv_bbl_v(i,J) - bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H + bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H + h_neglect if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) enddo ; endif @@ -1081,13 +1085,13 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, real :: I_Hmix ! The inverse of the mixed layer thickness [H-1 ~> m-1 or m2 kg-1]. real :: a_ml ! The layer coupling coefficient across an interface in ! the mixed layer [Z T-1 ~> m s-1]. - real :: I_amax ! The inverse of the maximum coupling coefficient [T s-1 Z-1 ~> m-1].??? + real :: I_amax ! The inverse of the maximum coupling coefficient [T Z-1 ~> s m-1]. real :: temp1 ! A temporary variable [H Z ~> m2 or kg m-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: z2 ! A copy of z_i [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] - real :: a_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] + real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] logical :: do_shelf, do_OBCs integer :: i, k, is, ie, max_nk integer :: nz @@ -1104,7 +1108,11 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! The maximum coupling coefficent was originally introduced to avoid ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 ! sets the maximum coupling coefficient increment to 1e10 m per timestep. - I_amax = (1.0e-10*US%Z_to_m) * dt + if (CS%answers_2018) then + I_amax = (1.0e-10*US%Z_to_m) * dt + else + I_amax = 0.0 + endif do_shelf = .false. ; if (present(shelf)) do_shelf = shelf do_OBCs = .false. @@ -1130,12 +1138,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, if (CS%bottomdraglaw) then r = hvel(i,nz)*0.5 if (r < bbl_thick(i)) then - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + r*GV%H_to_Z) + a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (r+h_neglect)*GV%H_to_Z) else - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + bbl_thick(i)*GV%H_to_Z) + a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (bbl_thick(i)+h_neglect)*GV%H_to_Z) endif else - a_cpl(i,nz+1) = CS%Kvbbl / (0.5*hvel(i,nz)*GV%H_to_Z + I_amax*CS%Kvbbl) + a_cpl(i,nz+1) = CS%Kvbbl / ((0.5*hvel(i,nz)+h_neglect)*GV%H_to_Z + I_amax*CS%Kvbbl) endif endif ; enddo @@ -1198,9 +1206,9 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, Kv_tot(i,K) = Kv_tot(i,K) + (kv_bbl(i) - CS%Kv)*botfn r = 0.5*(hvel(i,k) + hvel(i,k-1)) if (r > bbl_thick(i)) then - h_shear = ((1.0 - botfn) * r + botfn*bbl_thick(i)) + h_shear = ((1.0 - botfn) * r + botfn*bbl_thick(i)) + h_neglect else - h_shear = r + h_shear = r + h_neglect endif else Kv_tot(i,K) = Kv_tot(i,K) + (CS%Kvbbl-CS%Kv)*botfn @@ -1216,10 +1224,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, do i=is,ie ; if (do_i(i)) then if (work_on_u) then kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) - tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H + tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H + h_neglect else kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) - tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H + tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H + h_neglect endif z_t(i) = 0.0 @@ -1227,7 +1235,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, if (0.5*hvel(i,1) > tbl_thick(i)) then a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i)*GV%H_to_Z + I_amax*kv_TBL(i)) else - a_cpl(i,1) = kv_TBL(i) / (0.5*hvel(i,1)*GV%H_to_Z + I_amax*kv_TBL(i)) + a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect)*GV%H_to_Z + I_amax*kv_TBL(i)) endif endif ; enddo @@ -1237,13 +1245,13 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, r = 0.5*(hvel(i,k)+hvel(i,k-1)) if (r > tbl_thick(i)) then - h_shear = ((1.0 - topfn) * r + topfn*tbl_thick(i)) + h_shear = ((1.0 - topfn) * r + topfn*tbl_thick(i)) + h_neglect else - h_shear = r + h_shear = r + h_neglect endif - a_top = topfn * kv_TBL(i) - a_cpl(i,K) = a_cpl(i,K) + a_top / (h_shear*GV%H_to_Z + I_amax*a_top) + kv_top = topfn * kv_TBL(i) + a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear*GV%H_to_Z + I_amax*kv_top) endif ; enddo ; enddo elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0)) then max_nk = 0 @@ -1292,7 +1300,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) ! and be further limited by rotation to give the natural Ekman length. - visc_ml = u_star(i) * 0.41 * (temp1*u_star(i)) / (absf(i)*temp1 + h_ml(i)*u_star(i)) + visc_ml = u_star(i) * 0.41 * (temp1*u_star(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) * GV%H_to_Z + 0.5*I_amax*visc_ml) ! Choose the largest estimate of a. if (a_ml > a_cpl(i,K)) a_cpl(i,K) = a_ml @@ -1339,7 +1347,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS maxvel = CS%maxvel truncvel = 0.9*maxvel H_report = 6.0 * GV%Angstrom_H - dt_Rho0 = (US%L_T_to_m_s*US%Z_to_m) * dt / (GV%Rho0) + dt_Rho0 = (US%L_T_to_m_s*US%Z_to_m) * dt / GV%Rho0 if (len_trim(CS%u_trunc_file) > 0) then !$OMP parallel do default(shared) private(trunc_any,CFL) @@ -1536,6 +1544,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & real :: hmix_str_dflt real :: Kv_dflt ! A default viscosity [m2 s-1]. real :: Hmix_m ! A boundary layer thickness [m]. + logical :: default_2018_answers integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1559,6 +1568,14 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Default, read and log parameters call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", CS%answers_2018, & + "If true, use the order of arithmetic and expressions that recover the answers "//& + "from the end of 2018. Otherwise, use expressions that do not use an arbitary "//& + "and hard-coded maximum viscous coupling coefficient between layers.", & + default=default_2018_answers) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& "law of the form c_drag*|u|*u. The velocity magnitude "//& From 7951a843612a76ec57d818bf190429c3c53fddfc Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Tue, 31 Dec 2019 19:31:38 +0000 Subject: [PATCH 256/259] fix divide by zero --- src/user/MOM_wave_interface.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 0da6285f37..042df7c02f 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1069,10 +1069,14 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) sqrt( 2.0 * PI *kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) - else - UStokes_sl = 0.0 - LA=1.e8 + if(UStokes_sl .ne. 0.0)then + LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) + else + LA=1.e8 + endif + !else + ! UStokes_sl = 0.0 + ! LA=1.e8 endif end subroutine Get_StokesSL_LiFoxKemper From ae51d44ecafafaa5cab4da3fefc1ed71fb5cf7b8 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Tue, 31 Dec 2019 20:42:16 +0000 Subject: [PATCH 257/259] fix to wave_interface for debugging; looked safe but gave error about mixed complex and real variables --- src/user/MOM_wave_interface.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 042df7c02f..88a29f5577 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1072,11 +1072,12 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) if(UStokes_sl .ne. 0.0)then LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) else - LA=1.e8 + UStokes_sl = 0.0 + LA=1.e8 endif - !else - ! UStokes_sl = 0.0 - ! LA=1.e8 + else + UStokes_sl = 0.0 + LA=1.e8 endif end subroutine Get_StokesSL_LiFoxKemper From 40871c180d0497029e90ac0776f5340ac4573765 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 1 Jan 2020 13:07:09 +0000 Subject: [PATCH 258/259] more better way of fixing divide by zero --- src/user/MOM_wave_interface.F90 | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 88a29f5577..2d2e3cafd3 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1022,6 +1022,8 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) real :: z0, z0i, r1, r2, r3, r4, tmp, lasl_sqr_i real :: u10 + UStokes_sl = 0.0 + LA=1.e8 if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships call ust_2_u10_coare3p5(US%Z_to_m*US%s_to_T*ustar*sqrt(GV%Rho0/1.225), u10, GV, US) @@ -1069,15 +1071,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) sqrt( 2.0 * PI *kstar * z0) * & erfc( sqrt( 2.0 * kstar * z0 ) ) UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - if(UStokes_sl .ne. 0.0)then - LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) - else - UStokes_sl = 0.0 - LA=1.e8 - endif - else - UStokes_sl = 0.0 - LA=1.e8 + if(UStokes_sl .ne. 0.0)LA = sqrt(US%Z_to_m*US%s_to_T*ustar / UStokes_sl) endif end subroutine Get_StokesSL_LiFoxKemper From 926982002ab2007e7974af8606a66f75310207fe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Jan 2020 18:07:27 -0500 Subject: [PATCH 259/259] Corrected arguments to mct coupler iceberg calls Corrected arguments to iceberg_forces and iceberg_fluxes in the mct version of update_ocean_model. This should correct the recently introduced problems with compiling MOM6 with the mct coupler. --- config_src/mct_driver/mom_ocean_model_mct.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 63556c2750..fb98a7b2bf 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -528,7 +528,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%icebergs_alter_ocean) then if (do_dyn) & - call iceberg_forces(OS%grid, OS%US, OS%forces, OS%use_ice_shelf, & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & @@ -562,7 +562,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & - call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif