From 338f54b39c241fcaa62aeaf7d1ceb60839d13e53 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 3 Dec 2018 18:29:05 -0500 Subject: [PATCH 01/31] 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 02/31] 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 03/31] 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 04/31] 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 05/31] 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 06/31] 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 07/31] 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 08/31] 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 09/31] 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 10/31] 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 11/31] 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 12/31] 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 13/31] 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 14/31] 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 15/31] 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 16/31] 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 17/31] 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 18/31] 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 19/31] 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 20/31] 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 21/31] 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 22/31] 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 23/31] 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 24/31] 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 25/31] 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 26/31] 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 5937da2a02b4961c53dbaa8f0b8f9aa1de22ba5f Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 4 Sep 2019 13:41:31 -0600 Subject: [PATCH 27/31] 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 648c5b113fe8d30ef8a9e8eae9466c72b32c9c49 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 4 Sep 2019 17:02:42 -0600 Subject: [PATCH 28/31] 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 5024d44be26c0dd97db554bc9372f38cf87534ad Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 5 Sep 2019 08:47:31 -0600 Subject: [PATCH 29/31] 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 30/31] 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 5dcdacc2fa33b428c96259c44a530d345ed390d7 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 24 Sep 2019 16:21:23 -0600 Subject: [PATCH 31/31] 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