From 8e833d4d93476d38002bff7836f937a69b482bdb Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 Jun 2022 14:49:26 -0600 Subject: [PATCH 01/91] Add missing units Address comment from reviewer by adding units to covTS and varS. --- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 0c223ffdeb..864669a217 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -179,7 +179,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer ! densities [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: covTS, varS !SGS TS covariance, S variance in Stanley param; currently 0 + real, dimension(SZI_(G)) :: covTS, & !SGS TS covariance in Stanley param; currently 0 [degC ppt] + varS !SGS S variance in Stanley param; currently 0 [ppt2] real :: aFac, bFac ! Nondimensional ratios [nondim] real :: ddRho ! A density difference [R ~> kg m-3] real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] From 6057714230bed75fd3093a6b73d60c478e42c9ac Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 Jun 2022 14:51:44 -0600 Subject: [PATCH 02/91] Follow MOM6 code style guide * Add ``implicit none ; private`` to this module; * Put module variables into the control structure for this module; * Add the description of the units for all real variables; * Add a consistent two-point indent throughout the module . TODO: Without further modifications, adding ``private`` to the control structure of this module will break the model. Currently, MOM.F90 needs access to ``use_stoch_eos``, ``stanley_coeff``, and some of the diagnostic ids. --- src/core/MOM_stoch_eos.F90 | 234 +++++++++++++++++++------------------ 1 file changed, 121 insertions(+), 113 deletions(-) diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 index 0ee6d6b1be..bc5e15af4e 100644 --- a/src/core/MOM_stoch_eos.F90 +++ b/src/core/MOM_stoch_eos.F90 @@ -1,5 +1,6 @@ !> Provides the ocean stochastic equation of state module MOM_stoch_eos + ! This file is part of MOM6. See LICENSE.md for the license. use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type @@ -15,148 +16,156 @@ module MOM_stoch_eos use MOM_isopycnal_slopes,only : vert_fill_TS !use random_numbers_mod, only : getRandomNumbers,initializeRandomNumberStream,randomNumberStream -implicit none +implicit none; private #include public MOM_stoch_eos_init public MOM_stoch_eos_run public MOM_calc_varT -real,private ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: l2_inv - !< One over sum of the T cell side side lengths squared -real,private ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: rgauss !< nondimensional random Gaussian -real, parameter,private :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 -real, parameter,private :: amplitude=0.624499 !< Nondimensional std dev of Gaussian -integer ,private :: seed !< PRNG seed -type(PRNG) :: rn_CS !< PRNG control structure - !> Describes parameters of the stochastic component of the EOS !! correction, described in Stanley et al. JAMES 2020. type, public :: MOM_stoch_eos_CS - real,public ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: pattern - !< Random pattern for stochastic EOS + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: l2_inv + !< One over sum of the T cell side side lengths squared + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: rgauss + !< nondimensional random Gaussian + real :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 + real :: amplitude=0.624499 !< Nondimensional std dev of Gaussian + integer :: seed !< PRNG seed + type(PRNG) :: rn_CS !< PRNG control structure + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: pattern + !< Random pattern for stochastic EOS [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: phi - !< temporal correlation stochastic EOS (deugging) - logical :: use_stoch_eos !< If true, use the stochastic equation of state (Stanley et al. 2020) - real :: stanley_coeff !< Coefficient correlating the temperature gradient - !and SGS T variance; if <0, turn off scheme in all codes - real :: stanley_a ! m2 s-1] + !>@{ Diagnostic IDs integer :: id_stoch_eos = -1, id_stoch_phi = -1, id_tvar_sgs = -1 !>@} end type MOM_stoch_eos_CS - contains - subroutine MOM_stoch_eos_init(G,Time,param_file,stoch_eos_CS,restart_CS,diag) -! initialization subroutine called by MOM.F90, - type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< Time for stochastic process - type(MOM_stoch_eos_CS), intent(inout) :: stoch_eos_CS !< Stochastic control structure - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + +!> Initializes MOM_stoch_eos module. +subroutine MOM_stoch_eos_init(G,Time,param_file,CS,restart_CS,diag) + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< Time for stochastic process + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + + ! local variables integer :: i,j - type(vardesc) :: vd - seed=0 + type(vardesc) :: vd + CS%seed=0 ! contants !pi=2*acos(0.0) - call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", stoch_eos_CS%use_stoch_eos, & + call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", CS%use_stoch_eos, & "If true, stochastic perturbations are applied "//& "to the EOS in the PGF.", default=.false.) - call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", stoch_eos_CS%stanley_coeff, & + call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & "Coefficient correlating the temperature gradient "//& "and SGS T variance.", default=-1.0) - call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", stoch_eos_CS%stanley_a, & + call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", CS%stanley_a, & "Coefficient a which scales chi in stochastic perturbation of the "//& "SGS T variance.", default=1.0) - call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", stoch_eos_CS%kappa_smooth, & + call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & units="m2 s-1", default=1.0e-6) !don't run anything if STANLEY_COEFF < 0 - if (stoch_eos_CS%stanley_coeff >= 0.0) then + if (CS%stanley_coeff >= 0.0) then - ALLOC_(stoch_eos_CS%pattern(G%isd:G%ied,G%jsd:G%jed)) ; stoch_eos_CS%pattern(:,:) = 0.0 + ALLOC_(CS%pattern(G%isd:G%ied,G%jsd:G%jed)) ; CS%pattern(:,:) = 0.0 vd = var_desc("stoch_eos_pattern","nondim","Random pattern for stoch EOS",'h','1') - call register_restart_field(stoch_eos_CS%pattern, vd, .false., restart_CS) - ALLOC_(stoch_eos_CS%phi(G%isd:G%ied,G%jsd:G%jed)) ; stoch_eos_CS%phi(:,:) = 0.0 - ALLOC_(l2_inv(G%isd:G%ied,G%jsd:G%jed)) - ALLOC_(rgauss(G%isd:G%ied,G%jsd:G%jed)) - call get_param(param_file, "MOM_stoch_eos", "SEED_STOCH_EOS", seed, & + call register_restart_field(CS%pattern, vd, .false., restart_CS) + ALLOC_(CS%phi(G%isd:G%ied,G%jsd:G%jed)) ; CS%phi(:,:) = 0.0 + ALLOC_(CS%l2_inv(G%isd:G%ied,G%jsd:G%jed)) + ALLOC_(CS%rgauss(G%isd:G%ied,G%jsd:G%jed)) + call get_param(param_file, "MOM_stoch_eos", "SEED_STOCH_EOS", CS%seed, & "Specfied seed for random number sequence ", default=0) - call random_2d_constructor(rn_CS, G%HI, Time, seed) - call random_2d_norm(rn_CS, G%HI, rgauss) + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) ! fill array with approximation of grid area needed for decorrelation ! time-scale calculation do j=G%jsc,G%jec - do i=G%isc,G%iec - l2_inv(i,j)=1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2) - enddo + do i=G%isc,G%iec + CS%l2_inv(i,j)=1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2) + enddo enddo if (is_new_run(restart_CS)) then - do j=G%jsc,G%jec - do i=G%isc,G%iec - stoch_eos_CS%pattern(i,j)=amplitude*rgauss(i,j) - enddo - enddo + do j=G%jsc,G%jec + do i=G%isc,G%iec + CS%pattern(i,j)=CS%amplitude*CS%rgauss(i,j) + enddo + enddo endif !register diagnostics - stoch_eos_CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs', diag%axesTL, Time, & + CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs', diag%axesTL, Time, & 'Parameterized SGS Temperature Variance ', 'None') - if (stoch_eos_CS%use_stoch_eos) then - stoch_eos_CS%id_stoch_eos = register_diag_field('ocean_model', 'stoch_eos', diag%axesT1, Time, & + if (CS%use_stoch_eos) then + CS%id_stoch_eos = register_diag_field('ocean_model', 'stoch_eos', diag%axesT1, Time, & 'random pattern for EOS', 'None') - stoch_eos_CS%id_stoch_phi = register_diag_field('ocean_model', 'stoch_phi', diag%axesT1, Time, & + CS%id_stoch_phi = register_diag_field('ocean_model', 'stoch_phi', diag%axesT1, Time, & 'phi for EOS', 'None') endif endif - end subroutine MOM_stoch_eos_init +end subroutine MOM_stoch_eos_init - subroutine MOM_stoch_eos_run(G,u,v,delt,Time,stoch_eos_CS,diag) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. +!> Generates a pattern in space and time for the ocean stochastic equation of state +subroutine MOM_stoch_eos_run(G,u,v,delt,Time,CS,diag) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. - real, intent(in) :: delt !< Time step size for AR1 process [T ~> s]. - type(time_type), intent(in) :: Time !< Time for stochastic process - type(MOM_stoch_eos_CS), intent(inout) :: stoch_eos_CS !< Stochastic control structure - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics -! locals - integer :: i,j + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, intent(in) :: delt !< Time step size for AR1 process [T ~> s]. + type(time_type), intent(in) :: Time !< Time for stochastic process + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + + ! local variables + integer :: i,j integer :: yr,mo,dy,hr,mn,sc - real :: phi,ubar,vbar + real :: phi,ubar,vbar + + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) - call random_2d_constructor(rn_CS, G%HI, Time, seed) - call random_2d_norm(rn_CS, G%HI, rgauss) ! advance AR(1) do j=G%jsc,G%jec - do i=G%isc,G%iec - ubar=0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) - vbar=0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) - phi=exp(-delt*tfac*sqrt((ubar**2+vbar**2)*l2_inv(i,j))) - stoch_eos_CS%pattern(i,j)=phi*stoch_eos_CS%pattern(i,j) + amplitude*sqrt(1-phi**2)*rgauss(i,j) - stoch_eos_CS%phi(i,j)=phi - enddo + do i=G%isc,G%iec + ubar=0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) + vbar=0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) + phi=exp(-delt*CS%tfac*sqrt((ubar**2+vbar**2)*CS%l2_inv(i,j))) + CS%pattern(i,j)=phi*CS%pattern(i,j) + CS%amplitude*sqrt(1-phi**2)*CS%rgauss(i,j) + CS%phi(i,j)=phi + enddo enddo - end subroutine MOM_stoch_eos_run +end subroutine MOM_stoch_eos_run +!> Computes a parameterization of the SGS temperature variance +subroutine MOM_calc_varT(G,GV,h,tv,CS,dt) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness [H ~> m] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + real, intent(in) :: dt !< Time increment [T ~> s] - subroutine MOM_calc_varT(G,GV,h,tv,stoch_eos_CS,dt) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m] - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - type(MOM_stoch_eos_CS), intent(inout) :: stoch_eos_CS !< Stochastic control structure. - real, intent(in) :: dt !< Time increment [T ~> s] -! locals + ! local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & T, & !> The temperature (or density) [degC], with the values in !! in massless layers filled vertically by diffusion. @@ -171,42 +180,41 @@ subroutine MOM_calc_varT(G,GV,h,tv,stoch_eos_CS,dt) ! still a poor approximation in the interior when coordinates are strongly tilted. if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) - call vert_fill_TS(h, tv%T, tv%S, stoch_eos_CS%kappa_smooth*dt, T, S, G, GV, halo_here=1, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo_here=1, larger_h_denom=.true.) do k=1,G%ke - do j=G%jsc,G%jec - do i=G%isc,G%iec - hl(1) = h(i,j,k) * G%mask2dT(i,j) - hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) - hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) - hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) - hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - - ! SGS variance in i-direction [degC2] - dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & - + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & - ) * G%dxT(i,j) * 0.5 )**2 - ! SGS variance in j-direction [degC2] - dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & - + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & - ) * G%dyT(i,j) * 0.5 )**2 - tv%varT(i,j,k) = stoch_eos_CS%stanley_coeff * ( dTdi2 + dTdj2 ) - ! Turn off scheme near land - tv%varT(i,j,k) = tv%varT(i,j,k) * (minval(hl) / (maxval(hl) + GV%H_subroundoff)) - enddo - enddo + do j=G%jsc,G%jec + do i=G%isc,G%iec + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) + + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + tv%varT(i,j,k) = CS%stanley_coeff * ( dTdi2 + dTdj2 ) + ! Turn off scheme near land + tv%varT(i,j,k) = tv%varT(i,j,k) * (minval(hl) / (maxval(hl) + GV%H_subroundoff)) + enddo + enddo enddo ! if stochastic, perturb - if (stoch_eos_CS%use_stoch_eos) then - do k=1,G%ke - do j=G%jsc,G%jec - do i=G%isc,G%iec - tv%varT(i,j,k) = exp (stoch_eos_CS%stanley_a * stoch_eos_CS%pattern(i,j)) * tv%varT(i,j,k) - enddo + if (CS%use_stoch_eos) then + do k=1,G%ke + do j=G%jsc,G%jec + do i=G%isc,G%iec + tv%varT(i,j,k) = exp (CS%stanley_a * CS%pattern(i,j)) * tv%varT(i,j,k) enddo - enddo + enddo + enddo endif - end subroutine MOM_calc_varT +end subroutine MOM_calc_varT end module MOM_stoch_eos - From bb02a51becfbfbb9d7d46332fb6f4c77015e0881 Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 11:41:20 -0600 Subject: [PATCH 03/91] A new tracer that keeps track of "mixed layer age" has been added to the ideal age module. This PR also adds the ability to use the actual BL depth that is diagnosed by the active BL scheme inside the ideal age module (for all ideal age tracers). --- src/tracer/MOM_tracer_flow_control.F90 | 5 +- src/tracer/ideal_age_example.F90 | 227 +++++++++++++++++++++---- 2 files changed, 199 insertions(+), 33 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index d1c105fcd5..3dac584571 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -468,7 +468,8 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & - minimum_forcing_depth=minimum_forcing_depth) + minimum_forcing_depth=minimum_forcing_depth, & + Hml=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp, & @@ -544,7 +545,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp) + G, GV, US, CS%ideal_age_tracer_CSp, Hml=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 2fdeaff02f..92aab231a2 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -6,7 +6,7 @@ module ideal_age_example use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type @@ -31,8 +31,9 @@ module ideal_age_example public register_ideal_age_tracer, initialize_ideal_age_tracer public ideal_age_tracer_column_physics, ideal_age_tracer_surface_state public ideal_age_stock, ideal_age_example_end +public count_ML_layers -integer, parameter :: NTR_MAX = 3 !< the maximum number of tracers in this module. +integer, parameter :: NTR_MAX = 4 !< the maximum number of tracers in this module. !> The control structure for the ideal_age_tracer package type, public :: ideal_age_tracer_CS ; private @@ -49,9 +50,12 @@ module ideal_age_example real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. - real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. + real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1]. real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the !! surface value equals young_val, in years. + logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of + !! layers above the BL depth instead of the fixed nkml value. + integer :: ML_residence_num !! The tracer number assigned to the ML residence tracer in this module logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. @@ -64,6 +68,7 @@ module ideal_age_example type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart controls structure type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers + end type ideal_age_tracer_CS contains @@ -87,7 +92,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=48) :: var_name ! The variable's name. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_ideal_age_tracer - logical :: do_ideal_age, do_vintage, do_ideal_age_dated + logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_ML_residence integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -114,8 +119,14 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "the standard ideal age tracer - i.e. is set to 0 age in "//& "the mixed layer and ages at unit rate in the interior.", & default=.false.) - - + call get_param(param_file, mdl, "DO_ML_RESIDENCE", do_ML_residence, & + "If true, use a residence tracer that is set to 0 age "//& + "in the interior and ages at unit rate in the mixed layer.", & + default=.false.) + call get_param(param_file, mdl, "USE_REAL_BL_DEPTH", CS%use_real_BL_depth, & + "If true, the ideal age tracers will use the boundary layer "//& + "depth diagnosed from the BL or bulkmixedlayer scheme.", & + default=.false.) call get_param(param_file, mdl, "AGE_IC_FILE", CS%IC_file, & "The file in which the age-tracer initial values can be "//& "found, or an empty string for internal initialization.", & @@ -139,7 +150,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) if (do_ideal_age) then CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("age", "yr", "Ideal Age Tracer", cmor_field_name="agessc", caller=mdl) - CS%tracer_ages(m) = .true. ; CS%sfc_growth_rate(m) = 0.0 + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 endif @@ -147,7 +158,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("vintage", "yr", "Exponential Vintage Tracer", & caller=mdl) - CS%tracer_ages(m) = .false. ; CS%sfc_growth_rate(m) = 1.0/30.0 + CS%tracer_ages(m) = .false. ; CS%growth_rate(m) = 1.0/30.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 1e-20 ; CS%tracer_start_year(m) = 0.0 call get_param(param_file, mdl, "IDEAL_VINTAGE_START_YEAR", CS%tracer_start_year(m), & "The date at which the ideal vintage tracer starts.", & @@ -158,13 +169,21 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("age_dated","yr","Ideal Age Tracer with a Start Date",& caller=mdl) - CS%tracer_ages(m) = .true. ; CS%sfc_growth_rate(m) = 0.0 + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 call get_param(param_file, mdl, "IDEAL_AGE_DATED_START_YEAR", CS%tracer_start_year(m), & "The date at which the dated ideal age tracer starts.", & units="years", default=0.0) endif + CS%ML_residence_num = 0 + if (do_ML_residence) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%ML_residence_num = CS%ntr + CS%tr_desc(m) = var_desc("ML_age", "yr", "ML Residence Time Tracer", caller=mdl) + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 + CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 + endif + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) do m=1,CS%ntr @@ -220,6 +239,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB + logical :: use_real_BL_depth if (.not.associated(CS)) return if (CS%ntr < 1) return @@ -277,7 +297,7 @@ end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & - evap_CFL_limit, minimum_forcing_depth) + evap_CFL_limit, minimum_forcing_depth, Hml) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -302,6 +322,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hml !< Mixed layer depth [Z ~> m] + ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -309,13 +331,24 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: ML_layers ! Stores number of layers in mixed layer real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified - real :: sfc_val ! The surface value for the tracers. + real :: young_val ! The "young" value for the tracers. real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] real :: year ! The time in years. - integer :: i, j, k, is, ie, js, je, nz, m + real :: layer_frac + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (CS%use_real_BL_depth .and. .not. present(Hml)) then + call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, but no valid boundary layer scheme was found") + endif + + if (CS%use_real_BL_depth .and. present(Hml)) then + call count_ML_layers(G, GV, h_old, Hml, ML_layers) + endif + if (.not.associated(CS)) return if (CS%ntr < 1) return @@ -340,27 +373,123 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, year = US%s_to_T*time_type_to_real(CS%Time) * Isecs_per_year do m=1,CS%ntr - if (CS%sfc_growth_rate(m) == 0.0) then - sfc_val = CS%young_val(m) + + if (CS%growth_rate(m) == 0.0) then + young_val = CS%young_val(m) else - sfc_val = CS%young_val(m) * & - exp((year-CS%tracer_start_year(m)) * CS%sfc_growth_rate(m)) + young_val = CS%young_val(m) * & + exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) endif - do k=1,CS%nkml ; do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.0) then - CS%tr(i,j,k,m) = sfc_val - else - CS%tr(i,j,k,m) = CS%land_val(m) - endif - enddo ; enddo ; enddo - enddo - do m=1,CS%ntr ; if (CS%tracer_ages(m) .and. & - (year>=CS%tracer_start_year(m))) then -!$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) - do k=CS%nkml+1,nz ; do j=js,je ; do i=is,ie - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year - enddo ; enddo ; enddo - endif ; enddo + + if (m == CS%ML_residence_num) then + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(ML_layers(i,j)) + + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + + write(msg,*) TRIM("ML_layers= "),ML_layers(i,j), TRIM(", k= "),(k) + call MOM_error(NOTE,msg) + + if (G%mask2dT(i,j) > 0.0) then + layer_frac = ML_layers(i,j)-nk + layer_frac = 0.9 + CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + (1.-layer_frac) * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do j=js,je ; do i=is,ie + do k=1,CS%nkml + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + do k=CS%nkml+1,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + endif ! use real BL depth + + else ! if ML residence tracer + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(ML_layers(i,j)) + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + if (G%mask2dT(i,j) > 0.0) then + layer_frac = ML_layers(i,j)-nk + CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + layer_frac * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do k=1,CS%nkml ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo ; enddo ; enddo + + if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then + !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) + do k=CS%nkml+1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + enddo ; enddo ; enddo + endif + + + endif ! if use real BL depth + endif ! if ML residence tracer + + enddo ! loop over all tracers end subroutine ideal_age_tracer_column_physics @@ -448,6 +577,42 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end +subroutine count_ML_layers(G, GV, h, Hml, ML_layers) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: ML_layers !< Number of model layers in the mixed layer + + real :: current_depth + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ML_layers(:,:) = 0. + do j=js,je ; do i=is,ie + +! write(msg,*) TRIM("Hml= "),Hml(i,j) +! call MOM_error(NOTE,msg) + current_depth = 0. + do k=1,nz + current_depth = current_depth + h(i,j,k)*GV%H_to_Z + if (Hml(i,j) <= current_depth) then + ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) +! write(msg,*) TRIM("ML_layers(i,j) found = "),ML_layers(i,j) +! call MOM_error(NOTE,msg) + exit + else + ML_layers(i,j) = ML_layers(i,j) + 1.0 +! write(msg,*) TRIM("ML_layers(i,j) adding = "),ML_layers(i,j) +! call MOM_error(NOTE,msg) + endif + enddo + enddo ; enddo + +end subroutine count_ML_layers + !> \namespace ideal_age_example !! !! Originally by Robert Hallberg, 2002 From f415a7f5cc844730fd483bd5f4ad36ab04ec2fce Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 12:22:54 -0600 Subject: [PATCH 04/91] Shortens a line and removes whitespace --- src/tracer/ideal_age_example.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 92aab231a2..460b5cba41 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -342,7 +342,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (CS%use_real_BL_depth .and. .not. present(Hml)) then - call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, but no valid boundary layer scheme was found") + call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, & + but no valid boundary layer scheme was found") endif if (CS%use_real_BL_depth .and. present(Hml)) then @@ -599,7 +600,7 @@ subroutine count_ML_layers(G, GV, h, Hml, ML_layers) do k=1,nz current_depth = current_depth + h(i,j,k)*GV%H_to_Z if (Hml(i,j) <= current_depth) then - ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) + ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) ! write(msg,*) TRIM("ML_layers(i,j) found = "),ML_layers(i,j) ! call MOM_error(NOTE,msg) exit From 2428684ac7537412794297e5329c98de2b648c6f Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 12:37:09 -0600 Subject: [PATCH 05/91] !! ----> !< --- src/tracer/ideal_age_example.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 460b5cba41..c1d12b1594 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -55,7 +55,7 @@ module ideal_age_example !! surface value equals young_val, in years. logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of !! layers above the BL depth instead of the fixed nkml value. - integer :: ML_residence_num !! The tracer number assigned to the ML residence tracer in this module + integer :: ML_residence_num !< The tracer number assigned to the ML residence tracer in this module logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. From 0d86acd523280a7f762ac9aaa48b0b1d761499ec Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 12:46:01 -0600 Subject: [PATCH 06/91] Shortened line length to make dOxygen happy --- src/tracer/ideal_age_example.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index c1d12b1594..cc0f8c4cdf 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -404,7 +404,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, if (G%mask2dT(i,j) > 0.0) then layer_frac = ML_layers(i,j)-nk layer_frac = 0.9 - CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + (1.-layer_frac) * young_val + CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + (1.-layer_frac) * young_val else CS%tr(i,j,k,m) = CS%land_val(m) endif @@ -456,7 +457,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, k = MIN(nk+1,nz) if (G%mask2dT(i,j) > 0.0) then layer_frac = ML_layers(i,j)-nk - CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + layer_frac * young_val + CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + layer_frac * young_val else CS%tr(i,j,k,m) = CS%land_val(m) endif From 5ac624241c40e4381efe724ade3e0dab5e442368 Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 15:41:49 -0600 Subject: [PATCH 07/91] All references to "mixed layer" in the ideal age module now refer to "boundary layer" instead. --- src/tracer/ideal_age_example.F90 | 91 ++++++++++++++------------------ 1 file changed, 41 insertions(+), 50 deletions(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index cc0f8c4cdf..7351a7e459 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -31,7 +31,7 @@ module ideal_age_example public register_ideal_age_tracer, initialize_ideal_age_tracer public ideal_age_tracer_column_physics, ideal_age_tracer_surface_state public ideal_age_stock, ideal_age_example_end -public count_ML_layers +public count_BL_layers integer, parameter :: NTR_MAX = 4 !< the maximum number of tracers in this module. @@ -39,8 +39,8 @@ module ideal_age_example type, public :: ideal_age_tracer_CS ; private integer :: ntr !< The number of tracers that are actually used. logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. - integer :: nkml !< The number of layers in the mixed layer. The ideal - !1 age tracers are reset in the top nkml layers. + integer :: nkbl !< The number of layers in the boundary layer. The ideal + !1 age tracers are reset in the top nkbl layers. character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. @@ -54,8 +54,8 @@ module ideal_age_example real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the !! surface value equals young_val, in years. logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of - !! layers above the BL depth instead of the fixed nkml value. - integer :: ML_residence_num !< The tracer number assigned to the ML residence tracer in this module + !! layers above the BL depth instead of the fixed nkbl value. + integer :: BL_residence_num !< The tracer number assigned to the BL residence tracer in this module logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. @@ -92,7 +92,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=48) :: var_name ! The variable's name. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_ideal_age_tracer - logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_ML_residence + logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_BL_residence integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -107,21 +107,21 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DO_IDEAL_AGE", do_ideal_age, & "If true, use an ideal age tracer that is set to 0 age "//& - "in the mixed layer and ages at unit rate in the interior.", & + "in the boundary layer and ages at unit rate in the interior.", & default=.true.) call get_param(param_file, mdl, "DO_IDEAL_VINTAGE", do_vintage, & "If true, use an ideal vintage tracer that is set to an "//& - "exponentially increasing value in the mixed layer and "//& + "exponentially increasing value in the boundary layer and "//& "is conserved thereafter.", default=.false.) call get_param(param_file, mdl, "DO_IDEAL_AGE_DATED", do_ideal_age_dated, & "If true, use an ideal age tracer that is everywhere 0 "//& "before IDEAL_AGE_DATED_START_YEAR, but the behaves like "//& "the standard ideal age tracer - i.e. is set to 0 age in "//& - "the mixed layer and ages at unit rate in the interior.", & + "the boundary layer and ages at unit rate in the interior.", & default=.false.) - call get_param(param_file, mdl, "DO_ML_RESIDENCE", do_ML_residence, & + call get_param(param_file, mdl, "DO_BL_RESIDENCE", do_BL_residence, & "If true, use a residence tracer that is set to 0 age "//& - "in the interior and ages at unit rate in the mixed layer.", & + "in the interior and ages at unit rate in the boundary layer.", & default=.false.) call get_param(param_file, mdl, "USE_REAL_BL_DEPTH", CS%use_real_BL_depth, & "If true, the ideal age tracers will use the boundary layer "//& @@ -176,10 +176,10 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) units="years", default=0.0) endif - CS%ML_residence_num = 0 - if (do_ML_residence) then - CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%ML_residence_num = CS%ntr - CS%tr_desc(m) = var_desc("ML_age", "yr", "ML Residence Time Tracer", caller=mdl) + CS%BL_residence_num = 0 + if (do_BL_residence) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%BL_residence_num = CS%ntr + CS%tr_desc(m) = var_desc("BL_age", "yr", "BL Residence Time Tracer", caller=mdl) CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 endif @@ -249,7 +249,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS CS%Time => day CS%diag => diag - CS%nkml = max(GV%nkml,1) + CS%nkbl = max(GV%nkbl,1) do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=name, & @@ -297,7 +297,7 @@ end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & - evap_CFL_limit, minimum_forcing_depth, Hml) + evap_CFL_limit, minimum_forcing_depth, Hbl) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -322,7 +322,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hbl !< Boundary layer depth [Z ~> m] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -331,7 +331,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: ML_layers ! Stores number of layers in mixed layer + real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified real :: young_val ! The "young" value for the tracers. real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] @@ -341,13 +341,13 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - if (CS%use_real_BL_depth .and. .not. present(Hml)) then + if (CS%use_real_BL_depth .and. .not. present(Hbl)) then call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, & but no valid boundary layer scheme was found") endif - if (CS%use_real_BL_depth .and. present(Hml)) then - call count_ML_layers(G, GV, h_old, Hml, ML_layers) + if (CS%use_real_BL_depth .and. present(Hbl)) then + call count_BL_layers(G, GV, h_old, Hbl, BL_layers) endif if (.not.associated(CS)) return @@ -382,11 +382,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) endif - if (m == CS%ML_residence_num) then + if (m == CS%BL_residence_num) then if (CS%use_real_BL_depth) then do j=js,je ; do i=is,ie - nk = floor(ML_layers(i,j)) + nk = floor(BL_layers(i,j)) do k=1,nk if (G%mask2dT(i,j) > 0.0) then @@ -398,11 +398,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, k = MIN(nk+1,nz) - write(msg,*) TRIM("ML_layers= "),ML_layers(i,j), TRIM(", k= "),(k) - call MOM_error(NOTE,msg) - if (G%mask2dT(i,j) > 0.0) then - layer_frac = ML_layers(i,j)-nk + layer_frac = BL_layers(i,j)-nk layer_frac = 0.9 CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & *Isecs_per_year) + (1.-layer_frac) * young_val @@ -422,7 +419,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, else ! use real BL depth do j=js,je ; do i=is,ie - do k=1,CS%nkml + do k=1,CS%nkbl if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year else @@ -430,7 +427,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, endif enddo - do k=CS%nkml+1,nz + do k=CS%nkbl+1,nz if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = young_val else @@ -441,11 +438,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, endif ! use real BL depth - else ! if ML residence tracer + else ! if BL residence tracer if (CS%use_real_BL_depth) then do j=js,je ; do i=is,ie - nk = floor(ML_layers(i,j)) + nk = floor(BL_layers(i,j)) do k=1,nk if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = young_val @@ -456,7 +453,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, k = MIN(nk+1,nz) if (G%mask2dT(i,j) > 0.0) then - layer_frac = ML_layers(i,j)-nk + layer_frac = BL_layers(i,j)-nk CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & *Isecs_per_year) + layer_frac * young_val else @@ -473,7 +470,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo ; enddo else ! use real BL depth - do k=1,CS%nkml ; do j=js,je ; do i=is,ie + do k=1,CS%nkbl ; do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = young_val else @@ -483,14 +480,14 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) - do k=CS%nkml+1,nz ; do j=js,je ; do i=is,ie + do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year enddo ; enddo ; enddo endif endif ! if use real BL depth - endif ! if ML residence tracer + endif ! if BL residence tracer enddo ! loop over all tracers @@ -580,41 +577,35 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end -subroutine count_ML_layers(G, GV, h, Hml, ML_layers) +subroutine count_BL_layers(G, GV, h, Hbl, BL_layers) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: ML_layers !< Number of model layers in the mixed layer + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer real :: current_depth integer :: i, j, k, is, ie, js, je, nz, m, nk character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ML_layers(:,:) = 0. + BL_layers(:,:) = 0. do j=js,je ; do i=is,ie -! write(msg,*) TRIM("Hml= "),Hml(i,j) -! call MOM_error(NOTE,msg) current_depth = 0. do k=1,nz current_depth = current_depth + h(i,j,k)*GV%H_to_Z - if (Hml(i,j) <= current_depth) then - ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) -! write(msg,*) TRIM("ML_layers(i,j) found = "),ML_layers(i,j) -! call MOM_error(NOTE,msg) + if (Hbl(i,j) <= current_depth) then + BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / (h(i,j,k)*GV%H_to_Z)) exit else - ML_layers(i,j) = ML_layers(i,j) + 1.0 -! write(msg,*) TRIM("ML_layers(i,j) adding = "),ML_layers(i,j) -! call MOM_error(NOTE,msg) + BL_layers(i,j) = BL_layers(i,j) + 1.0 endif enddo enddo ; enddo -end subroutine count_ML_layers +end subroutine count_BL_layers !> \namespace ideal_age_example !! From e300296ac5c9fd9c3e6cf1aec791c70679dd75ba Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Mon, 1 Aug 2022 11:09:12 -0600 Subject: [PATCH 08/91] Changed GV%nkbl back to GV%nkml --- src/tracer/ideal_age_example.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 7351a7e459..ea9cbb3063 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -249,7 +249,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS CS%Time => day CS%diag => diag - CS%nkbl = max(GV%nkbl,1) + CS%nkbl = max(GV%nkml,1) do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=name, & From dfb37154abff846b5edf5116ef0940d77df6f61d Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Mon, 1 Aug 2022 11:16:47 -0600 Subject: [PATCH 09/91] Changed parameter reference for ideal_age_physics to Hbl=Hml --- src/tracer/MOM_tracer_flow_control.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 3dac584571..7520db820d 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -469,7 +469,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth, & - Hml=Hml) + Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp, & @@ -545,7 +545,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp, Hml=Hml) + G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp) From cfd7c0bdec86c07231447c3ed1a4ac9f93b6b47a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 22 Sep 2022 08:17:18 -0600 Subject: [PATCH 10/91] Rename parameter SMOOTH_RI to N_SMOOTH_RI In preparation for implementing the option to apply a vertical smooth filter in the Richardson number multiple times, the parameter SMOOTH_RI (logical) was renamed to N_SMOOTH_RI (interger). If N_SMOOTH_RI = 0 (default), smoothing is not performed. If N_SMOOTH_RI > 0, smoothing will be applied N_SMOOTH_RI times. --- src/parameterizations/vertical/MOM_CVMix_shear.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 7ec45dbe11..a84ec9ddd1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -31,7 +31,7 @@ module MOM_CVMix_shear type, public :: CVMix_shear_cs ! TODO: private logical :: use_LMD94 !< Flags to use the LMD94 scheme logical :: use_PP81 !< Flags to use Pacanowski and Philander (JPO 1981) - logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter + integer :: n_smooth_ri !< Number of times to smooth Ri using a 1-2-1 filter real :: Ri_zero !< LMD94 critical Richardson number real :: Nu_zero !< LMD94 maximum interior diffusivity real :: KPP_exp !< Exponent of unitless factor of diff. @@ -147,7 +147,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) - if (CS%smooth_ri) then + if (CS%n_smooth_ri) then ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) @@ -274,10 +274,10 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "Exponent of unitless factor of diffusivities, "// & "for KPP internal shear mixing scheme." & ,units="nondim", default=3.0) - call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & - "If true, vertically smooth the Richardson "// & - "number by applying a 1-2-1 filter once.", & - default = .false.) + call get_param(param_file, mdl, "N_SMOOTH_RI", CS%n_smooth_ri, & + "If > 0, vertically smooth the Richardson "// & + "number by applying a 1-2-1 filter N_SMOOTH_RI times.", & + default = 0) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & KPP_nu_zero=CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & From 09278521c10ba261b52e68e834b9899628455be3 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 22 Sep 2022 08:39:27 -0600 Subject: [PATCH 11/91] Modify gradient Richarson number diagnostics Currently, there are two diagnostics related to the gradient Richarson number and these are described as follows: * ri_grad_shear : Gradient Richarson number used by MOM_CVMix_shear module; * ri_grad_shear_smooth : Smoothed gradient Richarson number used by MOM_CVMix_shear module. The description for ri_grad_shear is misleading. If smoothing is applied, ri_grad_shear *is not* the RI number used by MOM_CVMix_shear module. In this commit. I propose to avoid this potential confusion by renaming ri_grad_shear_smooth to ri_grad_shear_orig and, if N_SMOOTH_RI > 0, use ri_grad_shear to store the smoothed profiles. * ri_grad_shear_orig : Original gradient Richarson number, before smoothing was applied. This is part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0. No change in answers for GMOM. --- .../vertical/MOM_CVMix_shear.F90 | 23 ++++++++++--------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index a84ec9ddd1..fca11423cb 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -39,14 +39,14 @@ module MOM_CVMix_shear real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [T-2 ~> s-2] real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number - real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number - !! after smoothing + real, allocatable, dimension(:,:,:) :: ri_grad_orig !< Gradient Richardson number + !! before smoothing character(10) :: Mix_Scheme !< Mixing scheme name (string) type(diag_ctrl), pointer :: diag => NULL() !< Pointer to the diagnostics control structure !>@{ Diagnostic handles integer :: id_N2 = -1, id_S2 = -1, id_ri_grad = -1, id_kv = -1, id_kd = -1 - integer :: id_ri_grad_smooth = -1 + integer :: id_ri_grad_orig = -1 !>@} end type CVMix_shear_cs @@ -145,9 +145,9 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) - if (CS%n_smooth_ri) then + if (CS%n_smooth_ri > 0) then ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) @@ -163,7 +163,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) dummy = 0.25 * Ri_grad(k) enddo - if (CS%id_ri_grad_smooth > 0) CS%ri_grad_smooth(i,j,:) = Ri_Grad(:) + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) endif do K=1,GV%ke+1 @@ -190,7 +190,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) if (CS%id_S2 > 0) call post_data(CS%id_S2, CS%S2, CS%diag) if (CS%id_ri_grad > 0) call post_data(CS%id_ri_grad, CS%ri_grad, CS%diag) - if (CS%id_ri_grad_smooth > 0) call post_data(CS%id_ri_grad_smooth ,CS%ri_grad_smooth, CS%diag) + if (CS%id_ri_grad_orig > 0) call post_data(CS%id_ri_grad_orig ,CS%ri_grad_orig, CS%diag) end subroutine calculate_CVMix_shear @@ -304,11 +304,12 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif - CS%id_ri_grad_smooth = register_diag_field('ocean_model', 'ri_grad_shear_smooth', & + CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & diag%axesTi, Time, & - 'Smoothed gradient Richarson number used by MOM_CVMix_shear module','nondim') - if (CS%id_ri_grad_smooth > 0) then !Initialize w/ large Richardson value - allocate( CS%ri_grad_smooth( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) + 'Original gradient Richarson number, before smoothing was applied. This is '//& + 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + if (CS%id_ri_grad_orig > 0 .or. CS%n_smooth_ri > 0) then !Initialize w/ large Richardson value + allocate( CS%ri_grad_orig( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & From b4440417c78eb585503cac8dc9f821bcef315e1e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 22 Sep 2022 14:16:21 -0600 Subject: [PATCH 12/91] Adds option to smooth gradient Ri multiple times This commit adds the option to smooth the gradient Richardson number multiple times using a 1-2-1 filter. The number of times that the filter is applied is controlled by parameter N_SMOOTH_RI. --- .../vertical/MOM_CVMix_shear.F90 | 41 ++++++++++++------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index fca11423cb..e3906e9df2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -72,7 +72,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous !! call to CVMix_shear_init. ! Local variables - integer :: i, j, k, kk, km1 + integer :: i, j, k, kk, km1, s real :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-1] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] @@ -85,7 +85,8 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) real, dimension(2*(GV%ke)) :: temp_1d ! A column of temperatures [C ~> degC] real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [S ~> ppt] real, dimension(2*(GV%ke)) :: rho_1d ! A column of densities at interface pressures [R ~> kg m-3] - real, dimension(GV%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] + real, dimension(GV%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] + real, dimension(GV%ke+1) :: Ri_Grad_prev !< Gradient Richardson number before s.th smoothing iteration [nondim] real, dimension(GV%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] real, dimension(GV%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] real :: epsln !< Threshold to identify vanished layers [H ~> m or kg m-2] @@ -145,9 +146,10 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) - if (CS%n_smooth_ri > 0) then + + if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) + ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) @@ -155,17 +157,24 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - ! 2) vertically smooth Ri with 1-2-1 filter - dummy = 0.25 * Ri_grad(2) - Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - do k = 3, GV%ke - Ri_Grad(k) = dummy + 0.5 * Ri_Grad(k) + 0.25 * Ri_grad(k+1) - dummy = 0.25 * Ri_grad(k) + do s=1,CS%n_smooth_ri + + Ri_Grad_prev(:) = Ri_Grad(:) + + ! 2) vertically smooth Ri with 1-2-1 filter + dummy = 0.25 * Ri_grad_prev(2) + do k = 3, GV%ke + Ri_Grad(k) = dummy + 0.5 * Ri_Grad_prev(k) + 0.25 * Ri_grad_prev(k+1) + dummy = 0.25 * Ri_grad(k) + enddo enddo - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + Ri_grad(GV%ke+1) = Ri_grad(GV%ke) + endif + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + do K=1,GV%ke+1 Kvisc(K) = US%Z2_T_to_m2_s * kv(i,j,K) Kdiff(K) = US%Z2_T_to_m2_s * kd(i,j,K) @@ -304,10 +313,12 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif - CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & - diag%axesTi, Time, & - 'Original gradient Richarson number, before smoothing was applied. This is '//& - 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + if (CS%n_smooth_ri > 0) then + CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & + diag%axesTi, Time, & + 'Original gradient Richarson number, before smoothing was applied. This is '//& + 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + endif if (CS%id_ri_grad_orig > 0 .or. CS%n_smooth_ri > 0) then !Initialize w/ large Richardson value allocate( CS%ri_grad_orig( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif From 0cf34d352e59f8a202e93de6d9b2290bb06ef74e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 7 Oct 2022 11:35:25 -0600 Subject: [PATCH 13/91] Fix string order in regional_section The correct order is lon_min lon_max lat_min lat_max ... and not lat_min lat_max lon_min lon_max. --- src/framework/_Diagnostics.dox | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/_Diagnostics.dox b/src/framework/_Diagnostics.dox index 3db345ca1a..0be318f580 100644 --- a/src/framework/_Diagnostics.dox +++ b/src/framework/_Diagnostics.dox @@ -90,7 +90,7 @@ An arbitrary number of lines, one per diagnostic field: "average" or "mean" performs a time-average. "min" or "max" diagnose the minium or maxium over each time period. -- `regional_section` : "none" means global output. A string of six space separated numbers, "lat_min, lat_max, lon_min, lon_max, vert_min, vert_max", limits the diagnostic to a region. +- `regional_section` : "none" means global output. A string of six space separated numbers, "lon_min lon_max lat_min lat_max vert_min vert_max", limits the diagnostic to a region. - `packing` : Data representation in the file. 1 means "real*8", 2 means "real*4", 4 mean 16-bit integers, 8 means 1-byte. From 380864138fb936e3e0bd76bb5155d74200e89db8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 7 Dec 2022 13:58:54 -0500 Subject: [PATCH 14/91] Switch from mpich to openmpi Testing to see if GH actions is failing due to MPI installation --- .github/actions/ubuntu-setup/action.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3fd2ea13cf..3f3ba5f0b6 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -13,7 +13,7 @@ runs: sudo apt-get install netcdf-bin sudo apt-get install libnetcdf-dev sudo apt-get install libnetcdff-dev - sudo apt-get install mpich - sudo apt-get install libmpich-dev + sudo apt-get install openmpi-bin + sudo apt-get install libopenmpi-dev sudo apt-get install linux-tools-common echo "::endgroup::" From a80b91dedf974415a73d13c1d8f653b1f6eb8350 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 11:13:50 -0700 Subject: [PATCH 15/91] use more cesm style logging --- config_src/drivers/nuopc_cap/mom_cap.F90 | 130 ++++++++++++----------- 1 file changed, 69 insertions(+), 61 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index b01e2019da..f1f2bdced6 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -5,16 +5,14 @@ module MOM_cap_mod use constants_mod, only: constants_init use diag_manager_mod, only: diag_manager_init, diag_manager_end use field_manager_mod, only: field_manager_init, field_manager_end -use fms_mod, only: fms_init, fms_end, open_namelist_file, check_nml_error -use fms_mod, only: close_file, file_exist, uppercase -use fms_io_mod, only: fms_io_exit -use mpp_domains_mod, only: domain2d, mpp_get_compute_domain, mpp_get_compute_domains +use mom_coms_infra, only: MOM_infra_init, MOM_infra_end +use mom_io_infra, only: io_infra_end +use mom_domain_infra, only: get_domain_extent +use MOM_io, only: stdout +use mpp_domains_mod, only: mpp_get_compute_domains use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain use mpp_domains_mod, only: mpp_get_domain_npes -use mpp_io_mod, only: mpp_open, MPP_RDONLY, MPP_ASCII, MPP_OVERWR, MPP_APPEND, mpp_close, MPP_SINGLE -use mpp_mod, only: stdlog, stdout, mpp_root_pe, mpp_clock_id -use mpp_mod, only: mpp_clock_begin, mpp_clock_end, MPP_CLOCK_SYNC -use mpp_mod, only: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, MAXPES + use time_manager_mod, only: set_calendar_type, time_type, increment_date use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR @@ -40,8 +38,7 @@ module MOM_cap_mod use MOM_cap_methods, only: ChkErr #ifdef CESMCOUPLED -use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit -use shr_mpi_mod, only : shr_mpi_min, shr_mpi_max +use shr_log_mod, only: shr_log_setLogUnit, shr_log_getLogUnit #endif use time_utils_mod, only: esmf2fms_time @@ -80,6 +77,7 @@ module MOM_cap_mod use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: ESMF_END_ABORT, ESMF_Finalize +use ESMF, only: ESMF_REDUCE_MAX, ESMF_REDUCE_MIN, ESMF_VMAllReduce use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -140,7 +138,6 @@ module MOM_cap_mod logical :: write_diagnostics = .false. logical :: overwrite_timeslice = .false. character(len=32) :: runtype !< run type -integer :: logunit !< stdout logging unit number logical :: profile_memory = .true. logical :: grid_attach_area = .false. logical :: use_coldstart = .true. @@ -489,7 +486,30 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !$ call omp_set_num_threads(nthrds) - call fms_init(mpi_comm_mom) + ! reset shr logging to my log file + if (localPet==0) then + call NUOPC_CompAttributeGet(gcomp, name="diro", & + isPresent=isPresentDiro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", & + isPresent=isPresentLogfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresentDiro .and. isPresentLogfile) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) + else + stdout = output_unit + endif + else + stdout = output_unit + endif + call shr_log_setLogUnit(stdout) + + call MOM_infra_init(mpi_comm_mom) + call constants_init call field_manager_init @@ -526,7 +546,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time_start = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) if (is_root_pe()) then - write(logunit,*) subname//'current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second + write(stdout,*) subname//'current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif ! get start/reference time @@ -538,33 +558,14 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) - if (is_root_pe()) then - write(logunit,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second - endif ! rsd need to figure out how to get this without share code !call shr_nuopc_get_component_instance(gcomp, inst_suffix, inst_index) !inst_name = "OCN"//trim(inst_suffix) - ! reset shr logging to my log file + if (is_root_pe()) then - call NUOPC_CompAttributeGet(gcomp, name="diro", & - isPresent=isPresentDiro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", & - isPresent=isPresentLogfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - else - logunit = output_unit - endif - else - logunit = output_unit + write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif starttype = "" @@ -659,7 +660,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ocean_model_init_sfc(ocean_state, ocean_public) - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) allocate ( Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & @@ -823,7 +824,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo - + if(is_root_pe()) write(stdout,*) 'InitializeAdvertise complete' end subroutine InitializeAdvertise !> Called by NUOPC to realize import and export fields. "Realizing" a field @@ -904,6 +905,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8) :: max_med2mod_areacor real(ESMF_KIND_R8) :: min_mod2med_areacor real(ESMF_KIND_R8) :: min_med2mod_areacor + + real(ESMF_KIND_R8) :: min_areacor(2) + real(ESMF_KIND_R8) :: max_areacor(2) + real(ESMF_KIND_R8) :: min_areacor_glob(2) + real(ESMF_KIND_R8) :: max_areacor_glob(2) + real(ESMF_KIND_R8) :: max_mod2med_areacor_glob real(ESMF_KIND_R8) :: max_med2mod_areacor_glob real(ESMF_KIND_R8) :: min_mod2med_areacor_glob @@ -913,7 +920,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) rc = ESMF_SUCCESS - call shr_file_setLogUnit (logunit) + call shr_log_setLogUnit (stdout) !---------------------------------------------------------------------------- ! Get pointers to ocean internal state @@ -1032,7 +1039,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (localPet == 0) then - write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) + write(stdout,*)'mesh file for mom6 domain is ',trim(cvalue) endif ! recreate the mesh using the above distGrid @@ -1060,7 +1067,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) n = 0 do j = jsc, jec jg = j + ocean_grid%jsc - jsc @@ -1148,19 +1155,20 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(model_areas) ! Write diagnostic output for correction factors - min_mod2med_areacor = minval(mod2med_areacor) - max_mod2med_areacor = maxval(mod2med_areacor) - min_med2mod_areacor = minval(med2mod_areacor) - max_med2mod_areacor = maxval(med2mod_areacor) - call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) - call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) - call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) - call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) + min_areacor(1) = minval(mod2med_areacor) + max_areacor(1) = maxval(mod2med_areacor) + min_areacor(2) = minval(med2mod_areacor) + max_areacor(2) = maxval(med2mod_areacor) + call ESMF_VMAllReduce(vm, min_areacor, min_areacor_glob, 2, ESMF_REDUCE_MIN, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllReduce(vm, max_areacor, max_areacor_glob, 2, ESMF_REDUCE_MAX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) then - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& - min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOM6' - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOM6' + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_areacor_glob(1), max_areacor_glob(1), 'MOM6' + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_areacor_glob(2), max_areacor_glob(2), 'MOM6' end if #endif @@ -1311,7 +1319,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! values for j=0 and wrap-around in i. on tripole seam, decomposition ! domains are 1 larger in j; to load corner values need to loop one extra row - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) lbnd1 = lbound(dataPtr_mask,1) ubnd1 = ubound(dataPtr_mask,1) @@ -1568,7 +1576,7 @@ subroutine ModelAdvance(gcomp, rc) rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") - call shr_file_setLogUnit (logunit) + call shr_log_setLogUnit (stdout) !$ call omp_set_num_threads(nthrds) @@ -1782,7 +1790,7 @@ subroutine ModelAdvance(gcomp, rc) endif if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) + write(stdout,*) subname//' writing restart file ',trim(restartname) endif endif endif ! restart_mode @@ -2039,8 +2047,8 @@ subroutine ocean_model_finalize(gcomp, rc) call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) call field_manager_end() - call fms_io_exit() - call fms_end() + call io_infra_end() + call MOM_infra_end() write(*,*) 'MOM: --- completed ---' @@ -2253,17 +2261,17 @@ end subroutine fld_list_add #ifndef CESMCOUPLED -subroutine shr_file_setLogUnit(nunit) +subroutine shr_log_setLogUnit(nunit) integer, intent(in) :: nunit ! do nothing for this stub - its just here to replace ! having cppdefs in the main program -end subroutine shr_file_setLogUnit +end subroutine shr_log_setLogUnit -subroutine shr_file_getLogUnit(nunit) +subroutine shr_log_getLogUnit(nunit) integer, intent(in) :: nunit ! do nothing for this stub - its just here to replace ! having cppdefs in the main program -end subroutine shr_file_getLogUnit +end subroutine shr_log_getLogUnit #endif !> @@ -2761,7 +2769,7 @@ end subroutine shr_file_getLogUnit !! with incoming coupling fields from other components. These three derived types are allocated during the !! [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase. Also during that !! phase, the `ice_ocean_boundary` type members are all allocated using bounds retrieved -!! from `mpp_get_compute_domain()`. +!! from `get_domain_extent()`. !! !! During the [InitializeRealize] (@ref MOM_cap_mod::initializerealize) phase, !! `ESMF_Field`s are created for each of the coupling fields in the `ice_ocean_boundary` From 7824dcec75baec29402f57714c4ae41550ae385a Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 12:19:04 -0700 Subject: [PATCH 16/91] switch to openmpi for github tests --- .github/actions/ubuntu-setup/action.yml | 4 ++-- config_src/drivers/nuopc_cap/mom_cap.F90 | 10 ---------- 2 files changed, 2 insertions(+), 12 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3fd2ea13cf..3f3ba5f0b6 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -13,7 +13,7 @@ runs: sudo apt-get install netcdf-bin sudo apt-get install libnetcdf-dev sudo apt-get install libnetcdff-dev - sudo apt-get install mpich - sudo apt-get install libmpich-dev + sudo apt-get install openmpi-bin + sudo apt-get install libopenmpi-dev sudo apt-get install linux-tools-common echo "::endgroup::" diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index f1f2bdced6..7b5bc38cae 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -901,20 +901,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8), allocatable :: mesh_areas(:) real(ESMF_KIND_R8), allocatable :: model_areas(:) real(ESMF_KIND_R8), pointer :: dataPtr_mesh_areas(:) - real(ESMF_KIND_R8) :: max_mod2med_areacor - real(ESMF_KIND_R8) :: max_med2mod_areacor - real(ESMF_KIND_R8) :: min_mod2med_areacor - real(ESMF_KIND_R8) :: min_med2mod_areacor - real(ESMF_KIND_R8) :: min_areacor(2) real(ESMF_KIND_R8) :: max_areacor(2) real(ESMF_KIND_R8) :: min_areacor_glob(2) real(ESMF_KIND_R8) :: max_areacor_glob(2) - - real(ESMF_KIND_R8) :: max_mod2med_areacor_glob - real(ESMF_KIND_R8) :: max_med2mod_areacor_glob - real(ESMF_KIND_R8) :: min_mod2med_areacor_glob - real(ESMF_KIND_R8) :: min_med2mod_areacor_glob character(len=*), parameter :: subname='(MOM_cap:InitializeRealize)' !-------------------------------- From 12238ae219238275ebc75cf6aa7249ba26657dfb Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 12:39:20 -0700 Subject: [PATCH 17/91] remove whitespace --- config_src/drivers/nuopc_cap/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 7b5bc38cae..4684b0e6ff 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -507,7 +507,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) stdout = output_unit endif call shr_log_setLogUnit(stdout) - + call MOM_infra_init(mpi_comm_mom) call constants_init From cac67d1e79a7a708881f6101a827cbadf71579e1 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 12:53:36 -0700 Subject: [PATCH 18/91] revert change to github action --- .github/actions/ubuntu-setup/action.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3f3ba5f0b6..3fd2ea13cf 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -13,7 +13,7 @@ runs: sudo apt-get install netcdf-bin sudo apt-get install libnetcdf-dev sudo apt-get install libnetcdff-dev - sudo apt-get install openmpi-bin - sudo apt-get install libopenmpi-dev + sudo apt-get install mpich + sudo apt-get install libmpich-dev sudo apt-get install linux-tools-common echo "::endgroup::" From 8bc69f67e7437aa13f949f8cff03d3e4c705c96c Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 13 Dec 2022 13:52:54 -0700 Subject: [PATCH 19/91] further improvement to logunit setting --- config_src/drivers/nuopc_cap/mom_cap.F90 | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 4684b0e6ff..08f564973b 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -38,7 +38,7 @@ module MOM_cap_mod use MOM_cap_methods, only: ChkErr #ifdef CESMCOUPLED -use shr_log_mod, only: shr_log_setLogUnit, shr_log_getLogUnit +use shr_log_mod, only: shr_log_setLogUnit #endif use time_utils_mod, only: esmf2fms_time @@ -507,7 +507,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) stdout = output_unit endif call shr_log_setLogUnit(stdout) - + call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, "logunit", logunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call MOM_infra_init(mpi_comm_mom) call constants_init @@ -2256,12 +2259,6 @@ subroutine shr_log_setLogUnit(nunit) ! do nothing for this stub - its just here to replace ! having cppdefs in the main program end subroutine shr_log_setLogUnit - -subroutine shr_log_getLogUnit(nunit) - integer, intent(in) :: nunit - ! do nothing for this stub - its just here to replace - ! having cppdefs in the main program -end subroutine shr_log_getLogUnit #endif !> From a789254e0fcbe31f675410507793ca2455f5cbe8 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 13 Dec 2022 15:09:58 -0700 Subject: [PATCH 20/91] get the variable name correct --- config_src/drivers/nuopc_cap/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 08f564973b..c909be8652 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -509,7 +509,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call shr_log_setLogUnit(stdout) call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, "logunit", logunit, rc=rc) + call NUOPC_CompAttributeSet(gcomp, "logunit", stdout, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call MOM_infra_init(mpi_comm_mom) From de8023d108daf91ea3af9036dd1e737876622e6d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 22 Dec 2022 13:09:18 -0500 Subject: [PATCH 21/91] POSIX: siglongjmp and sigsetjmp_missing fixes This patch fixes two issues in the POSIX API. The `siglongjmp` interface was referencing the wrong symbol (`longjmp`). While this did not seem to cause any issues, possibly due to some shared definitions on glibc/BSD platforms, the error was correctly detected by the Cray compiler. This patch corrects the C symbol name. The `sigsetjmp_missing` function, as a default replacement for a missing `sigsetjmp`, was also defined without a return value, since it always returns an error if called at runtime. The Cray compiler raised a warning about this, so we now assign a return value of -1, although it is never used. Thanks to Jim Edwards for reporting these errors. --- src/framework/posix.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 142d7634e2..e5ec0e60d4 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -188,7 +188,7 @@ end subroutine longjmp_posix !> C interface to POSIX siglongjmp() !! Users should use the Fortran-defined siglongjmp() function. - subroutine siglongjmp_posix(env, val) bind(c, name="longjmp") + subroutine siglongjmp_posix(env, val) bind(c, name="siglongjmp") ! #include ! int siglongjmp(jmp_buf env, int val); import :: sigjmp_buf, c_int @@ -360,6 +360,9 @@ function sigsetjmp_missing(env, savesigs) result(rc) bind(c) print '(a)', 'ERROR: sigsetjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DSIGSETJMP_NAME=\"\".' error stop + + ! NOTE: Compilers may expect a return value, even if it is unreachable + rc = -1 end function sigsetjmp_missing end module posix From 0f1fc0386928b3649fe841cc8a2896015f07a4fe Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 9 Jan 2023 13:31:41 -0700 Subject: [PATCH 22/91] fix gnu restart issue by removing leading spaces in restartfiles list --- config_src/drivers/nuopc_cap/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index d244205b1b..1abb7c9229 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -625,7 +625,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) ! GMM, this call is not needed in CESM. Check with EMC if it can be deleted. call ocean_model_flux_init(ocean_state) From b693dd2d81a7d4b3de7fc05011d5519e4d6101b8 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 12 Jan 2023 09:35:09 -0700 Subject: [PATCH 23/91] remove more direct calls to FMS in mom_cap.F90 --- config_src/drivers/nuopc_cap/mom_cap.F90 | 37 ++++++------------------ 1 file changed, 9 insertions(+), 28 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index b9090e9cec..6768a2f547 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -2,26 +2,18 @@ module MOM_cap_mod -use constants_mod, only: constants_init -use diag_manager_mod, only: diag_manager_init, diag_manager_end -use field_manager_mod, only: field_manager_init, field_manager_end -use mom_coms_infra, only: MOM_infra_init, MOM_infra_end -use mom_io_infra, only: io_infra_end -use mom_domain_infra, only: get_domain_extent -use MOM_io, only: stdout +use MOM_domains, only: get_domain_extent +use MOM_io, only: stdout, io_infra_end use mpp_domains_mod, only: mpp_get_compute_domains use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain use mpp_domains_mod, only: mpp_get_domain_npes -use time_manager_mod, only: set_calendar_type, time_type, increment_date -use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name -use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR -use time_manager_mod, only: operator( <= ), operator( < ), operator( >= ) -use time_manager_mod, only: operator( + ), operator( - ), operator( / ) -use time_manager_mod, only: operator( * ), operator( /= ), operator( > ) -use time_manager_mod, only: date_to_string -use time_manager_mod, only: fms_get_calendar_type => get_calendar_type -use MOM_domains, only: MOM_infra_init, num_pes, root_pe, pe_here +use MOM_time_manager, only: set_calendar_type, time_type, set_time, set_date, month_name +use MOM_time_manager, only: GREGORIAN, JULIAN, NOLEAP +use MOM_time_manager, only: operator( <= ), operator( < ), operator( >= ) +use MOM_time_manager, only: operator( + ), operator( - ), operator( / ) +use MOM_time_manager, only: operator( * ), operator( /= ), operator( > ) +use MOM_domains, only: MOM_infra_init, MOM_infra_end, num_pes, root_pe, pe_here use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file use MOM_get_input, only: get_MOM_input, directories use MOM_domains, only: pass_var @@ -486,9 +478,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call MOM_infra_init(mpi_comm_mom) - call constants_init - call field_manager_init - ! determine the calendar if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & @@ -514,8 +503,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call set_calendar_type (JULIAN) endif - call diag_manager_init - ! this ocean connector will be driven at set interval DT = set_time (DT_OCEAN, 0) ! get current time @@ -1987,7 +1974,6 @@ subroutine ocean_model_finalize(gcomp, rc) ESMF_LOGMSG_INFO) call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) - call field_manager_end() call io_infra_end() call MOM_infra_end() @@ -2337,8 +2323,7 @@ end subroutine shr_log_setLogUnit !! @subsection Initialization Initialization !! !! During the [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase, calls are -!! made to MOM's native initialization subroutines, including `fms_init()`, `constants_init()`, -!! `field_manager_init()`, `diag_manager_init()`, and `set_calendar_type()`. The MPI communicator +!! made to MOM's native initialization subroutines. The MPI communicator !! is pulled in through the ESMF VM object for the MOM component. The dt and start time are set !! from parameters from the incoming ESMF clock with calls to `set_time()` and `set_date().` !! @@ -2413,10 +2398,6 @@ end subroutine shr_log_setLogUnit !! procedures: !! !! call ocean_model_end (ocean_public, ocean_State, Time) -!! call diag_manager_end(Time ) -!! call field_manager_end -!! call fms_io_exit -!! call fms_end !! !! @section ModelFields Model Fields !! From 4959ee12fcba3ee01b4f91d98076885bf5e1a2ef Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Sun, 15 Jan 2023 20:52:39 -0700 Subject: [PATCH 24/91] update more write units to stdout in mom6 nuopc cap and let only rootpe write logs. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 8 +++++-- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 24 +++++++++---------- 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 6768a2f547..979dc3b25a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1948,7 +1948,9 @@ subroutine ocean_model_finalize(gcomp, rc) logical :: write_restart character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' - write(*,*) 'MOM: --- finalize called ---' + if (is_root_pe()) then + write(stdout,*) 'MOM: --- finalize called ---' + endif rc = ESMF_SUCCESS call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) @@ -1978,7 +1980,9 @@ subroutine ocean_model_finalize(gcomp, rc) call io_infra_end() call MOM_infra_end() - write(*,*) 'MOM: --- completed ---' + if (is_root_pe()) then + write(stdout,*) 'MOM: --- completed ---' + endif end subroutine ocean_model_finalize diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1fb35b31a6..808e6d44d9 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -53,7 +53,7 @@ module MOM_ocean_model_nuopc use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use fms_mod, only : stdout +use MOM_io, only : stdout use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only : Update_Surface_Waves, query_wave_properties @@ -446,7 +446,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call diag_mediator_close_registration(OS%diag) if (is_root_pe()) & - write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' call callTree_leave("ocean_model_init(") end subroutine ocean_model_init @@ -1123,20 +1123,18 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) ! Local variables integer(kind=int64) :: chks ! A checksum for the field logical :: root ! True only on the root PE - integer :: outunit ! The output unit to write to - outunit = stdout() root = is_root_pe() - if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks - chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks - chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks - chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks - chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks - chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks - chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks - call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') + if (root) write(stdout,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(stdout,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(stdout,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(stdout,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(stdout,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(stdout,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(stdout,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(stdout,100) 'ocean%melt_potential ', chks + call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) end subroutine ocean_public_type_chksum From 774074ff9db66da5434e910ef30a52fdfc376b31 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 6 Mar 2023 09:51:58 -0700 Subject: [PATCH 25/91] minor styling fixes to address PR #1594 reviews. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 8 +++---- src/tracer/ideal_age_example.F90 | 30 ++++++++++++------------ 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 76d541813e..b7d651bf55 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1687,10 +1687,10 @@ subroutine ModelAdvance(gcomp, rc) close(writeunit) endif else ! not cesm_coupled - write(restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & - ".MOM.res" - write(stoch_restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & - ".ocn_stoch.res.nc" + write(restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".MOM.res" + write(stoch_restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".ocn_stoch.res.nc" call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index e2d557ccb2..f0ad7cab99 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -379,7 +379,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, young_val = CS%young_val(m) else young_val = CS%young_val(m) * & - exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) + exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) endif if (m == CS%BL_residence_num) then @@ -409,11 +409,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do k=nk+2,nz - if (G%mask2dT(i,j) > 0.0) then - CS%tr(i,j,k,m) = young_val - else - CS%tr(i,j,k,m) = CS%land_val(m) - endif + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif enddo enddo ; enddo @@ -428,11 +428,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo do k=CS%nkbl+1,nz - if (G%mask2dT(i,j) > 0.0) then - CS%tr(i,j,k,m) = young_val - else - CS%tr(i,j,k,m) = CS%land_val(m) - endif + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif enddo enddo ; enddo @@ -479,10 +479,10 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo ; enddo ; enddo if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then - !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) - do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year - enddo ; enddo ; enddo + !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) + do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + enddo ; enddo ; enddo endif From ed93a232aa019a818a770e35ea53198abe72d7f5 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 6 Mar 2023 09:58:37 -0700 Subject: [PATCH 26/91] add SMOOTH_RI to MOM_obsolete_params.F90 --- src/diagnostics/MOM_obsolete_params.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index e686261fdf..c44aebf08d 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -97,6 +97,8 @@ subroutine find_obsolete_params(param_file) ! This parameter is on the to-do list to be obsoleted. ! call obsolete_logical(param_file, "NEW_SPONGES", hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") + call obsolete_logical(param_file, "SMOOTH_RI", hint="Instead use N_SMOOTH_RI.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) From d1d53bcb4c7ebf4263d35ef0420c95a5fb82a579 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 16 Mar 2023 18:31:37 -0600 Subject: [PATCH 27/91] remove inadvertent reassignment of layer_frac --- src/tracer/ideal_age_example.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index f0ad7cab99..dfa5e894db 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -400,7 +400,6 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, if (G%mask2dT(i,j) > 0.0) then layer_frac = BL_layers(i,j)-nk - layer_frac = 0.9 CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & *Isecs_per_year) + (1.-layer_frac) * young_val else From 588cf03adeed355e3db9a12a73c726f3b88b4c35 Mon Sep 17 00:00:00 2001 From: "Alan J. Wallcraft" Date: Sun, 19 Mar 2023 16:37:44 +0000 Subject: [PATCH 28/91] Add PPM_CM and HYCOM1_ONLY_IMPROVES Add "PPM_CW" as an option for INTERPOLATION_SCHEME and REMAPPING_SCHEME. This implements the original Colella and Woodward (1984) edge calculation for PPM. It computes 4th order explicit edge values but constrains them to produce a monotonic profile, which is particularly effective for remapping. INTERPOLATION_SCHEME="PPM_CW" is identical to "REMAPPING_PPM_HYBGEN", but hybgen_PPM_coefs has been replaced by edge_values_explicit_h4cw and PPM_monotonicity for flexibility and to simplify upgrades. Answers with existing INTERPOLATION_SCHEME options are unchanged. REMAPPING_SCHEME="PPM_CW" is a new option which can perform better than "P1M_H2" when used with INTERPOLATION_SCHEME="PPM_CW". Answers with existing REMAPPING_SCHEME options are unchanged. HYCOM1 regridding walks a monotonic density profile to locate the new interface locations where the interface density equals the target density. However, it assumes that moving one interface has no effect on the density at all other interfaces and this need not be the case. When regridding, with HYCOM1_ONLY_IMPROVES=True, an interface is only moved if this improves the fit to its target density. The default of False does not change answers. --- src/ALE/MOM_ALE.F90 | 4 +- src/ALE/MOM_regridding.F90 | 17 +++-- src/ALE/MOM_remapping.F90 | 17 ++++- src/ALE/PPM_functions.F90 | 31 ++++++++- src/ALE/coord_hycom.F90 | 122 +++++++++++++++++++++++++++++---- src/ALE/regrid_edge_values.F90 | 102 ++++++++++++++++++++++++++- src/ALE/regrid_interp.F90 | 27 +++++++- 7 files changed, 297 insertions(+), 23 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 2a9ebc09c8..137f6cee9b 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -206,12 +206,12 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& - "It can be one of the following schemes: "//& + "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call get_param(param_file, mdl, "VELOCITY_REMAPPING_SCHEME", vel_string, & "This sets the reconstruction scheme used for vertical remapping "//& "of velocities. By default it is the same as REMAPPING_SCHEME. "//& - "It can be one of the following schemes: "//& + "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=trim(string)) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 53072909a5..5e46b8d1f6 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -166,6 +166,7 @@ module MOM_regridding " P1M_H4 (2nd-order accurate)\n"//& " P1M_IH4 (2nd-order accurate)\n"//& " PLM (2nd-order accurate)\n"//& + " PPM_CW (3rd-order accurate)\n"//& " PPM_H4 (3rd-order accurate)\n"//& " PPM_IH4 (3rd-order accurate)\n"//& " P3M_IH4IH3 (4th-order accurate)\n"//& @@ -269,7 +270,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "determine the new grid. These parameters are "//& "only relevant when REGRIDDING_COORDINATE_MODE is "//& "set to a function of state. Otherwise, it is not "//& - "used. It can be one of the following schemes: "//& + "used. It can be one of the following schemes: \n"//& trim(regriddingInterpSchemeDoc), default=trim(string2)) call set_regrid_params(CS, interp_scheme=string) @@ -582,6 +583,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_params(CS, min_thickness=0.) endif + if (main_parameters .and. coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then + call get_param(param_file, mdl, "HYCOM1_ONLY_IMPROVES", tmpLogical, & + "When regridding, an interface is only moved if this improves the fit to the target density.", & + default=.false.) + call set_hycom_params(CS%hycom_CS, only_improves=tmpLogical) + endif + CS%use_hybgen_unmix = .false. if (coordinateMode(coord_mode) == REGRIDDING_HYBGEN) then call get_param(param_file, mdl, "USE_HYBGEN_UNMIX", CS%use_hybgen_unmix, & @@ -865,7 +873,7 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & call build_grid_arbitrary( G, GV, h, dzInterface, trickGnuCompiler, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) + call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) case ( REGRIDDING_HYBGEN ) call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -1515,12 +1523,13 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } -subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) +subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position @@ -1575,7 +1584,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_she ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, GV%ke, nominalDepth, & + call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, nominalDepth, & h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & z_col, z_col_new, zScale=GV%Z_to_H, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 9ebc0601d2..eeb4590a08 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -8,12 +8,14 @@ module MOM_remapping use MOM_io, only : stdout, stderr use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use remapping_attic, only : remapping_attic_unit_tests use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 use MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs @@ -48,6 +50,7 @@ module MOM_remapping integer, parameter :: REMAPPING_PCM = 0 !< O(h^1) remapping scheme integer, parameter :: REMAPPING_PLM = 2 !< O(h^2) remapping scheme integer, parameter :: REMAPPING_PLM_HYBGEN = 3 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PPM_CW =10 !< O(h^3) remapping scheme integer, parameter :: REMAPPING_PPM_H4 = 4 !< O(h^3) remapping scheme integer, parameter :: REMAPPING_PPM_IH4 = 5 !< O(h^3) remapping scheme integer, parameter :: REMAPPING_PPM_HYBGEN = 6 !< O(h^3) remapping scheme @@ -287,7 +290,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & local_remapping_scheme = REMAPPING_PCM elseif (n0<=3) then local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PLM ) - elseif (n0<=4) then + elseif (n0<=4 .and. local_remapping_scheme /= REMAPPING_PPM_CW ) then local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PPM_H4 ) endif select case ( local_remapping_scheme ) @@ -310,6 +313,15 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & if ( CS%boundary_extrapolation ) & call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) iMethod = INTEGRATION_PLM + case ( REMAPPING_PPM_CW ) + ! identical to REMAPPING_PPM_HYBGEN + call edge_values_explicit_h4cw( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call PPM_monotonicity( n0, u0, ppoly_r_E ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) + if ( CS%boundary_extrapolation ) then + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) @@ -1283,6 +1295,9 @@ subroutine setReconstructionType(string,CS) case ("PLM_HYBGEN") CS%remapping_scheme = REMAPPING_PLM_HYBGEN degree = 1 + case ("PPM_CW") + CS%remapping_scheme = REMAPPING_PPM_CW + degree = 2 case ("PPM_H4") CS%remapping_scheme = REMAPPING_PPM_H4 degree = 2 diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index aa24806d68..805a70d502 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -13,7 +13,7 @@ module PPM_functions implicit none ; private -public PPM_reconstruction, PPM_boundary_extrapolation +public PPM_reconstruction, PPM_boundary_extrapolation, PPM_monotonicity !> A tiny width that is so small that adding it to cell widths does not !! change the value due to a computational representation. It is used @@ -127,6 +127,35 @@ subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date ) end subroutine PPM_limiter_standard +!> Adjusts edge values using the original monotonicity constraint (Colella & Woodward, JCP 1984) +!! Based on hybgen_ppm_coefs +subroutine PPM_monotonicity( N, u, edge_values ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + + ! Local variables + integer :: k ! Loop index + real :: a6,da ! scalar temporaries + + ! Loop on interior cells to impose monotonicity + ! Eq. 1.10 of (Colella & Woodward, JCP 84) + do k = 2,N-1 + if (((u(k+1)-u(k))*(u(k)-u(k-1)) <= 0.)) then !local extremum + edge_values(k,1) = u(k) + edge_values(k,2) = u(k) + else + da = edge_values(k,2)-edge_values(k,1) + a6 = 6.0*u(k) - 3.0*(edge_values(k,1)+edge_values(k,2)) + if (da*a6 > da*da) then !peak in right half of zone + edge_values(k,1) = 3.0*u(k) - 2.0*edge_values(k,2) + elseif (da*a6 < -da*da) then !peak in left half of zone + edge_values(k,2) = 3.0*u(k) - 2.0*edge_values(k,1) + endif + endif + enddo ! end loop on interior cells + +end subroutine PPM_monotonicity !------------------------------------------------------------------------------ !> Reconstruction by parabolas within boundary cells diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 5a3ffaff52..aa2715eb42 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -4,8 +4,10 @@ module coord_hycom ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL +use MOM_remapping, only : remapping_CS, remapping_core_h use MOM_EOS, only : EOS_type, calculate_density -use regrid_interp, only : interp_CS_type, build_and_interpolate_grid +use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, regridding_set_ppolys +use regrid_interp, only : DEGREE_MAX implicit none ; private @@ -27,6 +29,9 @@ module coord_hycom !> Maximum thicknesses of layers [H ~> m or kg m-2] real, allocatable, dimension(:) :: max_layer_thickness + !> If true, an interface only moves if it improves the density fit + logical :: only_improves = .false. + !> Interpolation control structure type(interp_CS_type) :: interp_CS end type hycom_CS @@ -69,10 +74,11 @@ subroutine end_coord_hycom(CS) end subroutine end_coord_hycom !> This subroutine can be used to set the parameters for the coord_hycom module -subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) +subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_improves, interp_CS) type(hycom_CS), pointer :: CS !< Coordinate control structure real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] + logical, optional, intent(in) :: only_improves !< If true, an interface only moves if it improves the density fit type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") @@ -91,13 +97,16 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, inter CS%max_layer_thickness(:) = max_layer_thickness(:) endif + if (present(only_improves)) CS%only_improves = only_improves + if (present(interp_CS)) CS%interp_CS = interp_CS end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & +subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) @@ -116,8 +125,17 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & ! Local variables integer :: k - real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] - real, dimension(CS%nk) :: h_col_new ! New layer thicknesses + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(CS%nk) :: h_col_new ! New layer thicknesses [H ~> m or kg m-2] + real, dimension(CS%nk) :: r_col_new ! New layer densities [R ~> kg m-3] + real, dimension(CS%nk) :: T_col_new ! New layer temperatures [C ~> degC] + real, dimension(CS%nk) :: S_col_new ! New layer salinities [S ~> ppt] + real, dimension(CS%nk) :: p_col_new ! New layer pressure [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: RiA_ini ! Initial nk+1 interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real, dimension(CS%nk+1) :: RiA_new ! New interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real :: z_1, z_nz ! mid point of 1st and last layers [H ~> m or kg m-2] real :: z_scale ! A scaling factor from the input thicknesses to the target thicknesses, ! perhaps 1 or a factor in [H Z-1 ~> 1 or kg m-3] real :: stretching ! z* stretching, converts z* to z [nondim]. @@ -130,18 +148,43 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & z_scale = 1.0 ; if (present(zScale)) z_scale = zScale - ! Work bottom recording potential density - call calculate_density(T, S, p_col, rho_col, eqn_of_state) - ! This ensures the potential density profile is monotonic - ! although not necessarily single valued. - do k = nz-1, 1, -1 - rho_col(k) = min( rho_col(k), rho_col(k+1) ) - enddo + if (CS%only_improves .and. nz == CS%nk) then + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + h, T, S, p_col, rho_col, RiA_ini, h_neglect, h_neglect_edge) + else + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + endif ! Interpolates for the target interface position with the rho_col profile ! Based on global density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + if (CS%only_improves .and. nz == CS%nk) then + ! Only move an interface if it improves the density fit + z_1 = 0.5 * ( z_col(1) + z_col(2) ) + z_nz = 0.5 * ( z_col(nz) + z_col(nz+1) ) + do k = 1,CS%nk + p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) / ( z_nz - z_1 ) * & + ( p_col(nz) - p_col(1) ) + enddo + ! Remap from original h and T,S to get T,S_col_new + call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new, h_neglect, h_neglect_edge) + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + h_col_new, T_col_new, S_col_new, p_col_new, r_col_new, RiA_new, h_neglect, h_neglect_edge) + do k= 2,CS%nk + if ( abs(RiA_ini(K)) <= abs(RiA_new(K)) .and. z_col(K) > z_col_new(K-1) .and. & + z_col(K) < z_col_new(K+1)) then + z_col_new(K) = z_col(K) + endif + enddo + endif !only_improves ! Sweep down the interfaces and make sure that the interface is at least ! as deep as a nominal target z* grid @@ -165,4 +208,59 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & enddo ; endif end subroutine build_hycom1_column +!> Calculate interface density anomaly w.r.t. the target. +subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & + R, RiAnom, h_neglect, h_neglect_edge) + type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: nz !< Number of levels + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] + !! to desired units for zInterface, perhaps GV%Z_to_H. + real, dimension(nz), intent(out) :: R !< Layer density [R ~> kg m-3] + real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly + !! w.r.t. the interface target + !! densities [R ~> kg m-3] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! cell reconstruction [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of + !! edge value calculation [H ~> m or kg m-2] + ! Local variables + integer :: degree,k + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_E ! Polynomial edge values [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_S ! Polynomial edge slopes [R H-1] + real, dimension(nz,DEGREE_MAX+1) :: ppoly_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3] + + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + + call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h, ppoly_E, ppoly_S, ppoly_C, & + degree, h_neglect, h_neglect_edge) + + R(1) = rho_col(1) + RiAnom(1) = ppoly_E(1,1) - CS%target_density(1) + do k= 2,nz + R(k) = rho_col(k) + if (ppoly_E(k-1,2) > CS%target_density(k)) then + RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target + elseif (ppoly_E(k,1) < CS%target_density(k)) then + RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target + else + RiAnom(k) = 0.0 !interface spans the target + endif + enddo + RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1) + +end subroutine build_hycom1_target_anomaly + end module coord_hycom diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 3f59fac60f..9b574348af 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -14,7 +14,7 @@ module regrid_edge_values ! The following routines are visible to the outside world ! ----------------------------------------------------------------------------- public bound_edge_values, average_discontinuous_edge_values, check_discontinuous_edge_values -public edge_values_explicit_h2, edge_values_explicit_h4 +public edge_values_explicit_h2, edge_values_explicit_h4, edge_values_explicit_h4cw public edge_values_implicit_h4, edge_values_implicit_h6 public edge_slopes_implicit_h3, edge_slopes_implicit_h5 @@ -357,6 +357,106 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) end subroutine edge_values_explicit_h4 +!> Compute h4 edge values (explicit fourth order accurate) +!! in the same units as u. +!! +!! From (Colella & Woodward, JCP, 1984) and based on hybgen_ppm_coefs. +!! +!! Compute edge values based on fourth-order explicit estimates. +!! These estimates are based on a cubic interpolant spanning four cells +!! and evaluated at the location of the middle edge. An interpolant spanning +!! cells i-2, i-1, i and i+1 is evaluated at edge i-1/2. The estimate for +!! each edge is unique. +!! +!! i-2 i-1 i i+1 +!! ..--o------o------o------o------o--.. +!! i-1/2 +!! +!! For this fourth-order scheme, at least four cells must exist. +subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + + ! Local variables + real :: dp(N) ! Input grid layer thicknesses, but with a minimum thickness [H ~> m or kg m-2] + real :: hNeglect ! A negligible thickness in the same units as h + real :: da ! Difference between the unlimited scalar edge value estimates [A] + real :: a6 ! Scalar field differences that are proportional to the curvature [A] + real :: slk, srk ! Differences between adjacent cell averages of scalars [A] + real :: sck ! Scalar differences across a cell. + real :: au(N) ! Scalar field difference across each cell [A] + real :: al(N), ar(N) ! Scalar field at the left and right edges of a cell [A] + real :: h112(N+1), h122(N+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(N+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(N) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(N) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Set the thicknesses for very thin layers to some minimum value. + do k=1,N ; dp(k) = max(h(k), hNeglect) ; enddo + + !compute grid metrics + do k=2,N + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,N-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,N-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + !Compute average slopes: Colella, Eq. (1.8) + au(1) = 0. + do k=2,N-1 + slk = u(k )-u(k-1) + srk = u(k+1)-u(k) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + au(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + au(k) = 0. + endif + enddo !k + au(N) = 0. + + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = u(1) ! 1st layer PCM + ar(1) = u(1) ! 1st layer PCM + al(2) = u(1) ! 1st layer PCM + do K=3,N-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*u(k-1) + dp(k-1)*u(k)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(u(k)-u(k-1)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*au(k-1)*h23_h122(K) - dp(k-1)*au(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo !k + ar(N-1) = u(N) ! last layer PCM + al(N) = u(N) ! last layer PCM + ar(N) = u(N) ! last layer PCM + + !Set coefficients + do k=1,N + edge_val(k,1) = al(k) + edge_val(k,2) = ar(k) + enddo !k + +end subroutine edge_values_explicit_h4cw + !> Compute ih4 edge values (implicit fourth order accurate) !! in the same units as u. !! diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 4d09daf6f3..e119ce9d53 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -7,11 +7,13 @@ module regrid_interp use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h2, edge_values_explicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 use P1M_functions, only : P1M_interpolation, P1M_boundary_extrapolation @@ -45,6 +47,7 @@ module regrid_interp integer, parameter :: INTERPOLATION_P1M_H4 = 1 !< O(h^2) integer, parameter :: INTERPOLATION_P1M_IH4 = 2 !< O(h^2) integer, parameter :: INTERPOLATION_PLM = 3 !< O(h^2) +integer, parameter :: INTERPOLATION_PPM_CW =10 !< O(h^3) integer, parameter :: INTERPOLATION_PPM_H4 = 4 !< O(h^3) integer, parameter :: INTERPOLATION_PPM_IH4 = 5 !< O(h^3) integer, parameter :: INTERPOLATION_P3M_IH4IH3 = 6 !< O(h^4) @@ -144,6 +147,25 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) endif + case ( INTERPOLATION_PPM_CW ) + if ( n0 >= 4 ) then + degree = DEGREE_2 + call edge_values_explicit_h4cw( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call PPM_monotonicity( n0, densities, ppoly0_E ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 @@ -486,7 +508,7 @@ end function get_polynomial_coordinate !> Numeric value of interpolation_scheme corresponding to scheme name integer function interpolation_scheme(interp_scheme) character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme - !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" select case ( uppercase(trim(interp_scheme)) ) @@ -494,6 +516,7 @@ integer function interpolation_scheme(interp_scheme) case ("P1M_H4"); interpolation_scheme = INTERPOLATION_P1M_H4 case ("P1M_IH2"); interpolation_scheme = INTERPOLATION_P1M_IH4 case ("PLM"); interpolation_scheme = INTERPOLATION_PLM + case ("PPM_CW"); interpolation_scheme = INTERPOLATION_PPM_CW case ("PPM_H4"); interpolation_scheme = INTERPOLATION_PPM_H4 case ("PPM_IH4"); interpolation_scheme = INTERPOLATION_PPM_IH4 case ("P3M_IH4IH3"); interpolation_scheme = INTERPOLATION_P3M_IH4IH3 @@ -509,7 +532,7 @@ end function interpolation_scheme subroutine set_interp_scheme(CS, interp_scheme) type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme - !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" CS%interpolation_scheme = interpolation_scheme(interp_scheme) From 1bb66a44c27242f3390906267e545d9f4f7e32f8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Feb 2023 09:39:25 -0500 Subject: [PATCH 29/91] +Update check_MOM6_scaling_factors with C and S Updated check_MOM6_scaling_factors and compose_dimension_list to reflect that fact that MOM6 is now doing dimensional consistency testing for temperature (via [C ~> degC]) and salinity (via [S ~> ppt]), with an expanded dimension of the scaling key from 6 to 8 and additional calls to add_scaling. Also updated the weights on the add_scaling calls, which are essentially counts of the frequency of the various unit descriptors in the MOM6 code, to reflect only the counts of variables with doxygen comments (i.e., arguments, function return values and elements of types) but excluding the user, framework and diagnostics directories and the passive tracer packages. All model solutions are bitwise identical, but there will be updated suggestions for combinations of scaling factors that minimize the aliasing of the units that are used. --- src/core/MOM_check_scaling.F90 | 248 +++++++++++++++++---------------- 1 file changed, 131 insertions(+), 117 deletions(-) diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90 index 55bd471fee..1d7c27b6fd 100644 --- a/src/core/MOM_check_scaling.F90 +++ b/src/core/MOM_check_scaling.F90 @@ -28,19 +28,23 @@ subroutine check_MOM6_scaling_factors(GV, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - integer, parameter :: ndims = 6 ! The number of rescalable dimensional factors. + integer, parameter :: ndims = 8 ! The number of rescalable dimensional factors. real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units. integer, dimension(ndims) :: scale_pow2 ! The powers of 2 that give each element of scales. character(len=2), dimension(ndims) :: key - ! character(len=128) :: mesg, msg_frag integer, allocatable :: weights(:) character(len=80), allocatable :: descriptions(:) - ! logical :: verbose, very_verbose integer :: n, ns, max_pow + ! If no scaling is being done, simply return. + if ((US%Z_to_m == 1.) .and. (GV%H_to_MKS == 1.) .and. (US%L_to_m == 1.) .and. & + (US%T_to_s == 1.) .and. (US%R_to_kg_m3 == 1.) .and. (US%Q_to_J_kg == 1.) .and. & + (US%C_to_degC == 1.) .and. (US%S_to_ppt == 1.)) return + ! Set the names and scaling factors of the dimensions being rescaled. - key(:) = ["Z", "H", "L", "T", "R", "Q"] - scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg /) + key(:) = ["Z", "H", "L", "T", "R", "Q", "C", "S"] + scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg, & + US%C_to_degC, US%S_to_ppt/) call scales_to_powers(scales, scale_pow2) max_pow = 40 ! 60 @@ -71,124 +75,134 @@ subroutine compose_dimension_list(ns, des, wts) !! perhaps the number of times it occurs in the MOM6 code. ns = 0 - ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence. - call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 1239) ! Layer thicknesses - call add_scaling(ns, des, wts, "[Z ~> m]", 660) ! Depths and vertical distance - call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 506) ! Horizontal velocities - call add_scaling(ns, des, wts, "[R ~> kg m-3]", 356) ! Densities - call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 247) ! Rates - call add_scaling(ns, des, wts, "[T ~> s]", 237) ! Time intervals - call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 231) ! Dynamic pressure + ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence in + ! doxygen comments (i.e., arguments and elements in types), excluding the code in the user, ice_shelf and + ! framework directories and the passive tracer packages. + call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 716) ! Layer thicknesses + call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 264) ! Horizontal velocities + call add_scaling(ns, des, wts, "[Z ~> m]", 244) ! Depths and vertical distance + call add_scaling(ns, des, wts, "[T ~> s]", 154) ! Time intervals + call add_scaling(ns, des, wts, "[S ~> ppt]", 135) ! Salinities + call add_scaling(ns, des, wts, "[C ~> degC]", 135) ! Temperatures + call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 133) ! Dynamic pressure ! call add_scaling(ns, des, wts, "[R L2 T-2 ~> J m-3]") ! Energy density - call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 181) ! Vertical viscosities and diffusivities - call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 174) ! Cell volumes or masses - call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 163) ! Volume or mass transports - call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 136) ! Horizontal accelerations - call add_scaling(ns, des, wts, "[L ~> m]", 107) ! Horizontal distances - call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 104) ! Friction velocities and viscous coupling - call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 89) ! Inverse cell thicknesses - call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 88) ! Resolved kinetic energy per unit mass - call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 85) ! Integrated turbulent kinetic energy density - call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 78) ! Horizontal viscosity or diffusivity - call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 69) ! Squared shears and buoyancy frequency - call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 68) ! Lateral cell face areas - call add_scaling(ns, des, wts, "[L2 ~> m2]", 67) ! Horizontal areas - - call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 61) ! Specific volumes - call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 62) ! Vertical heat fluxes - call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 60) ! Inverse vertical distances - call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 57) ! Gravitational acceleration - call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 52) ! Vertical mass fluxes - call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 51) ! Vertical thickness fluxes - call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 45) ! Integrated turbulent kinetic energy sources - call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 42) ! Layer or column mass loads - call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 33) ! Integrated turbulent kinetic energy sources - call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 35) ! Squared layer thicknesses - call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 33) ! Turbulent kinetic energy - call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 32) ! Inverse horizontal distances - call add_scaling(ns, des, wts, "[R L Z T-2 ~> Pa]", 27) ! Wind stresses - call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 33) ! Inverse velocities squared - call add_scaling(ns, des, wts, "[R Z L2 T-2 ~> J m-2]", 25) ! Integrated energy - ! call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]") ! Depth integral of pressures (25) - call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 25) ! Integrated energy - call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 24) ! Layer-integrated density - call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 20) ! pbce or gtot - call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 19) ! Laplacian of velocity - - call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 18) ! Biharmonic viscosity - call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 17) ! Layer integrated velocities - call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 15) ! Slopes - call add_scaling(ns, des, wts, "[Z L2 ~> m3]", 14) ! Diagnostic volumes - call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 12) ! Layer integrated velocities - call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 14) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] - call add_scaling(ns, des, wts, "[Z2 ~> m2]", 12) ! Squared vertical distances - call add_scaling(ns, des, wts, "[R Z L2 T-1 ~> kg s-1]", 12) ! Mass fluxes - call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 12) ! Inverse areas - call add_scaling(ns, des, wts, "[L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]", 11) ! Gravitational acceleration over density - call add_scaling(ns, des, wts, "[Z T-2 ~> m s-2]", 10) ! Buoyancy differences or their derivatives - ! Could also add [Z T-2 degC-1 ~> m s-2 degC-1] or [Z T-2 ppt-1 ~> m s-2 ppt-1] - call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 10) ! Energy sources, including for MEKE - call add_scaling(ns, des, wts, "[L3 ~> m3]", 10) ! Metric dependent constants for viscosity - call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 9) ! Inverse of denominator in some weighted averages - call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 9) ! Mixed layer local work variables - call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 9) ! Overturning (GM) streamfunction - call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 9) ! Buoyancy frequency in some params. - call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 8) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 132) ! Vertical viscosities and diffusivities + call add_scaling(ns, des, wts, "[R ~> kg m-3]", 122) ! Densities + + call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 97) ! Volume or mass transports + call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 91) ! Cell volumes or masses + call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 82) ! Horizontal accelerations + call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 67) ! Rates + call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 56) ! Friction velocities and viscous coupling + call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 42) ! Vertical heat fluxes + call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 45) ! Horizontal viscosity or diffusivity + call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 37) ! Resolved kinetic energy per unit mass + call add_scaling(ns, des, wts, "[L ~> m]", 35) ! Horizontal distances + call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 33) ! Squared shears and buoyancy frequency + + call add_scaling(ns, des, wts, "[R Z L T-2 ~> Pa]", 33) ! Wind stresses + call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 32) ! Lateral cell face areas + call add_scaling(ns, des, wts, "[L2 ~> m2]", 31) ! Horizontal areas + call add_scaling(ns, des, wts, "[R C-1 ~> kg m-3 degC-1]", 26) ! Thermal expansion coefficients + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 26) ! Gravitational acceleration + call add_scaling(ns, des, wts, "[R S-1 ~> kg m-3 ppt-1]", 23) ! Haline contraction coefficients + call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 23) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 19) ! Vertical mass fluxes + call add_scaling(ns, des, wts, "[C H ~> degC m or degC kg m-2]", 17) ! Heat content + call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 17) ! Inverse cell thicknesses + + call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 14) ! Inverse vertical distances + call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 14) ! Specific volumes + call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 12) ! Slopes + call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 12) ! Inverse horizontal distances + call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 12) ! pbce or gtot + call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 11) ! Layer or column mass loads + call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 11) ! Integrated energy per unit mass + call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 11) ! Integrated turbulent kinetic energy density + call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 9) ! Vertical thickness fluxes + call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 9) ! Laplacian of velocity + + call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 9) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[S H ~> ppt m or ppt kg m-2]", 8) ! Depth integrated salinity + call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 8) ! Turbulent kinetic energy + call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]", 7) ! Vertically integrated pressure anomalies call add_scaling(ns, des, wts, "[Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd) - call add_scaling(ns, des, wts, "[Q degC-1 ~> J kg-1 degC-1]", 7) ! Heat capacity - - call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 6) ! Potential energy height derivatives - call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 7) ! Partial derivatives of energy - call add_scaling(ns, des, wts, "[R L2 T-2 Z-1 ~> Pa m-1]", 7) ! Converts depth to pressure - call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 7) ! Rigidity of ice - call add_scaling(ns, des, wts, "[H L2 T-3 ~> m3 s-3]", 9) ! Kinetic energy diagnostics - call add_scaling(ns, des, wts, "[H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]", 6) ! Layer potential vorticity - call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 3) ! Kinetic energy dissipation rates - call add_scaling(ns, des, wts, "[Z2 L-2 ~> 1]", 1) ! Slopes squared - call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 6) ! Thickness to height conversion - call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 6) ! Pressure conversion factor - ! Could also add [m T2 R-1 L-2 ~> m Pa-1] - ! Could also add [degC T2 R-1 L-2 ~> degC Pa-1] - call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 5) ! Vertical density gradients + call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 7) ! Biharmonic viscosity + call add_scaling(ns, des, wts, "[L3 ~> m3]", 7) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 7) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] + call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 7) ! Squared layer thicknesses + call add_scaling(ns, des, wts, "[C H T-1 ~> degC m s-1 or degC kg m-2 s-1]", 7) ! vertical heat fluxes + + call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 6) ! Inverse areas + call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 6) ! Energy sources, including for MEKE + call add_scaling(ns, des, wts, "[Z2 T-3 ~> m2 s-3]", 5) ! Certain buoyancy fluxes + call add_scaling(ns, des, wts, "[Z2 ~> m2]", 5) ! Squared vertical distances + call add_scaling(ns, des, wts, "[S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]", 5) ! vertical salinity fluxes + call add_scaling(ns, des, wts, "[R-1 C-1 ~> m3 kg-1 degC-1]", 5) ! Specific volume temperature gradient + call add_scaling(ns, des, wts, "[R-1 S-1 ~> m3 kg-1 ppt-1]", 4) ! Specific volume salnity gradient + call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 4) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z C-1 ~> m degC-1]", 4) ! Inverse temperature gradients + call add_scaling(ns, des, wts, "[Z S-1 ~> m ppt-1]", 4) ! Inverse salinity gradients + + call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 4) ! Partial derivatives of energy + call add_scaling(ns, des, wts, "[R Z3 T-2 S-1 ~> J m-2 ppt-1]", 4) ! Sensitity of energy change to salinity + call add_scaling(ns, des, wts, "[R Z3 T-2 C-1 ~> J m-2 degC-1]", 4) ! Sensitity of energy change to temperature call add_scaling(ns, des, wts, "[R L4 T-4 ~> Pa m2 s-2]", 4) ! Integral in geopotential of pressure - call add_scaling(ns, des, wts, "[L Z-1 ~> nondim]", 4) ! Inverse slopes + call add_scaling(ns, des, wts, "[Q ~> J kg-1]", 4) ! Latent heats + call add_scaling(ns, des, wts, "[Q C-1 ~> J kg-1 degC-1]", 4) ! Heat capacity call add_scaling(ns, des, wts, "[L-3 ~> m-3]", 4) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 4) ! Buoyancy frequency in some params. + call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 4) ! Layer-integrated density + call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 4) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[H T2 L-1 ~> s2 or kg s2 m-3]", 4) ! BT_cont_type face curvature fit call add_scaling(ns, des, wts, "[H L-1 ~> nondim or kg m-3]", 4) ! BT_cont_type face curvature fit - call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 20) ! Diagnostic conversions to mass - ! Could also add [m3 H-1 L-2 ~> 1 or m3 kg-1] - call add_scaling(ns, des, wts, "[Z T-2 R-1 ~> m4 s-2 kg-1]", 9) ! Gravitational acceleration over density - call add_scaling(ns, des, wts, "[R Z L4 T-3 ~> kg m2 s-3]", 9) ! MEKE fluxes - call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 3) ! Thickness to pressure conversion - - call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 3) ! Inverse of column mass - call add_scaling(ns, des, wts, "[L4 ~> m4]", 3) ! Metric dependent constants for viscosity - call add_scaling(ns, des, wts, "[T-1 Z-1 ~> s-1 m-1]", 2) ! Barotropic PV, for some options - call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 2) ! River mixing term [R Z2 T-1 ~> Pa s] - call add_scaling(ns, des, wts, "[degC Q-1 ~> kg degC J-1]", 2) ! Inverse heat capacity - ! Could add call add_scaling(ns, des, wts, "[Q-1 ~> kg J-1]", 1) ! Inverse heat content - call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 2) ! Ice rigidity term - call add_scaling(ns, des, wts, "[R Z-1 ~> kg m-4]", 3) ! Vertical density gradient - call add_scaling(ns, des, wts, "[R Z L2 ~> kg]", 3) ! Depth and time integrated mass fluxes - call add_scaling(ns, des, wts, "[R L2 T-3 ~> W m-2]", 3) ! Depth integrated friction work - call add_scaling(ns, des, wts, "[ppt2 R-2 ~> ppt2 m6 kg-2]", 3) ! T / S gauge transformation - call add_scaling(ns, des, wts, "[R L-1 ~> kg m-4]", 2) ! Horizontal density gradient - ! Could add call add_scaling(ns, des, wts, "[H Z ~> m2 or kg m-1]", 2) ! Temporary variables - call add_scaling(ns, des, wts, "[Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]", 2) ! Heating to PE change - call add_scaling(ns, des, wts, "[R2 L2 Z2 T-4 ~> Pa2]", 2) ! Squared wind stresses - call add_scaling(ns, des, wts, "[L-2 T-2 ~> m-2 s-2]", 2) ! Squared Laplacian of velocity - call add_scaling(ns, des, wts, "[T H Z-1 ~> s or s kg m-3]", 2) ! Time step times thickness conversion - call add_scaling(ns, des, wts, "[T H Z-1 R-1 ~> s m3 kg-1 or s]", 2) ! Time step over density with conversion - call add_scaling(ns, des, wts, "[H-3 ~> m-3 or m6 kg-3]", 1) ! A local term in ePBL - call add_scaling(ns, des, wts, "[H-4 ~> m-4 or m8 kg-4]", 1) ! A local term in ePBL - call add_scaling(ns, des, wts, "[H T Z-2 ~> s m-1 or kg s m-4]", 1) ! A local term in ePBL - - call add_scaling(ns, des, wts, "[H3 ~> m3 or kg3 m-6]", 1) ! Thickness cubed in a denominator - call add_scaling(ns, des, wts, "[H2 T-2 ~> m2 s-2 or kg2 m-4 s-2]", 1) ! Thickness times f squared - call add_scaling(ns, des, wts, "[H T2 R-1 Z-2 ~> m Pa-1 or s2 m-1]", 1) ! Pressure to thickness conversion - call add_scaling(ns, des, wts, "[L2 Z-2 ~> nondim]", 1) ! Inverse slope squared - call add_scaling(ns, des, wts, "[H R L2 T-2 ~> m Pa]", 1) ! Integral in thickness of pressure - call add_scaling(ns, des, wts, "[R T2 Z-1 ~> kg s2 m-4]", 1) ! Density divided by gravitational acceleration + call add_scaling(ns, des, wts, "[C2 ~> degC2]", 4) ! Squared temperature anomalies + call add_scaling(ns, des, wts, "[S2 ~> ppt2]", 3) ! Squared salinity anomalies + call add_scaling(ns, des, wts, "[C S ~> degC ppt]", 3) ! Covariance of temperature and salinity anomalies + call add_scaling(ns, des, wts, "[S R Z ~> gSalt m-2]", 3) ! Total ocean column salt + call add_scaling(ns, des, wts, "[C R Z ~> degC kg m-2]", 3) ! Total ocean column temperature + call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 3) ! Pressure conversions + call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 3) ! Thickness to height conversion + call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 3) ! Potential energy height derivatives + + call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 3) ! Mixed layer local work variables + call add_scaling(ns, des, wts, "[C S-1 ~> degC ppt-1]", 2) ! T / S gauge transformation + call add_scaling(ns, des, wts, "[R S-2 ~> kg m-3 ppt-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R C-2 ~> kg m-3 degC-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R S-1 C-1 ~> kg m-3 ppt-1 degC-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 2) ! Inverse velocities squared + call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 2) ! Kinetic energy dissipation rates + call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 2) ! Vertical density gradients + + call add_scaling(ns, des, wts, "[L4 ~> m4]", 2) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 2) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[C Z ~> degC m]", 2) ! Depth integrated temperature + call add_scaling(ns, des, wts, "[S Z ~> ppt m]", 1) ! Layer integrated salinity + call add_scaling(ns, des, wts, "[T L4 ~> s m4]", 2) ! Biharmonic metric dependent constant + call add_scaling(ns, des, wts, "[L6 ~> m6]", 2) ! Biharmonic Leith metric dependent constant + call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 2) ! Rigidity of ice + call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 1) ! Ice rigidity term + call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 1) ! Inverse of column mass + call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 1) ! Inverse of denominator in some weighted averages + + call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 1) ! River mixing term + call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 1) ! Thickness to pressure conversion + call add_scaling(ns, des, wts, "[Z T2 R-1 L-2 ~> m Pa-1]", 1) ! Atmospheric pressure SSH correction + call add_scaling(ns, des, wts, "[T Z ~> s m] ", 1) ! Time integrated SSH + call add_scaling(ns, des, wts, "[Z-1 T-1 ~> m-1 s-1]", 1) ! barotropic PV + call add_scaling(ns, des, wts, "[L2 T ~> m2 s]", 1) ! Greatbatch & Lamb 90 coefficient + call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 1) ! Overturning (GM) streamfunction + call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 1) ! Diagnostic conversions to mass + call add_scaling(ns, des, wts, "[S-1 ~> ppt-1]", 1) ! Unscaling salinity + call add_scaling(ns, des, wts, "[C-1 ~> degC-1]", 1) ! Unscaling temperature + + call add_scaling(ns, des, wts, "[R Z H-1 ~> kg m-3 or 1] ", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H R-1 Z-1 ~> m3 kg-2 or 1]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H Z-1 ~> 1 or kg m-3]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[m T s-1 L-1 ~> 1]", 1) ! A unit conversion factor end subroutine compose_dimension_list From 19f861314c21f3b24fa2c7bb951e6fc73761a854 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Mar 2023 09:31:41 -0400 Subject: [PATCH 30/91] +(*)Remove coord_SLight Removed the coord_slight module and all calls to it, and obsoleted all run-time parameters that are exclusively related to it. This code was an attempt from 2015 to define an appropriate hybrid vertical coordinate for global climate modeling, but it never worked very well (usually falling apart in the second year), and it has not been used in any publication or active model for many years. The test case that exercised this coordinate in the MOM6-examples test suite is also being removed via MOM6-examples PR #388. The coord_SLight code is being eliminated altogether now to simplify the MOM6 code base and reduce the volume of untested and unused code. All answers in all known MOM6 configurations in active use are bitwise identical, although there is a remote chance that someone somewhere might be using the SLIGHT coordinate. --- src/ALE/MOM_regridding.F90 | 188 +----- src/ALE/coord_slight.F90 | 733 ------------------------ src/ALE/regrid_consts.F90 | 6 - src/diagnostics/MOM_obsolete_params.F90 | 8 + src/framework/MOM_diag_remap.F90 | 4 - 5 files changed, 18 insertions(+), 921 deletions(-) delete mode 100644 src/ALE/coord_slight.F90 diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 5e46b8d1f6..b9d74c01a2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -22,7 +22,7 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR -use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE +use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike @@ -30,7 +30,6 @@ module MOM_regridding use coord_rho, only : init_coord_rho, rho_CS, set_rho_params, build_rho_column, end_coord_rho use coord_rho, only : old_inflate_layers_1d use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom -use coord_slight, only : init_coord_slight, slight_CS, set_slight_params, build_slight_column, end_coord_slight use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid use MOM_hybgen_regrid, only : write_Hybgen_coord_file @@ -61,7 +60,7 @@ module MOM_regridding !! This array is the nominal coordinate of interfaces and is the !! running sum of coordinateResolution, in [R ~> kg m-3]. i.e. !! target_density(k+1) = coordinateResolution(k) + coordinateResolution(k) - !! It is only used in "rho", "SLight" or "Hycom" mode. + !! It is only used in "rho" or "Hycom" mode. real, dimension(:), allocatable :: target_density !> A flag to indicate that the target_density arrays has been filled with data. @@ -129,7 +128,6 @@ module MOM_regridding type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator type(hycom_CS), pointer :: hycom_CS => null() !< Control structure for hybrid coordinate generator - type(slight_CS), pointer :: slight_CS => null() !< Control structure for Slight-coordinate generator type(adapt_CS), pointer :: adapt_CS => null() !< Control structure for adaptive coordinate generator type(hybgen_regrid_CS), pointer :: hybgen_CS => NULL() !< Control structure for hybgen regridding @@ -157,7 +155,6 @@ module MOM_regridding " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& " HYBGEN - Hybrid coordinate from the Hycom hybgen code\n"//& - " SLIGHT - stretched coordinates above continuous isopycnal\n"//& " ADAPTIVE - optimize for smooth neutral density surfaces" !> Documentation for regridding interpolation schemes @@ -209,18 +206,17 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m character(len=200) :: inputdir, fileName character(len=320) :: message ! Temporary strings character(len=12) :: expected_units, alt_units ! Temporary strings - logical :: tmpLogical, fix_haloclines, do_sum, main_parameters + logical :: tmpLogical, do_sum, main_parameters logical :: coord_is_state_dependent, ierr integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the remapping expressions to use. - real :: filt_len, strat_tol, tmpReal, P_Ref + real :: tmpReal, P_Ref real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). - real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] - integer :: nz_fixed_sfc, k, nzf(4) + integer :: k, nzf(4) real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2] @@ -489,7 +485,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (coordinateMode(coord_mode) == REGRIDDING_ZSTAR .or. & coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. & coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. & - coordinateMode(coord_mode) == REGRIDDING_SLIGHT .or. & coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then ! Adjust target grid to be consistent with maximum_depth tmpReal = sum( dz(:) ) @@ -597,49 +592,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m default=.false.) endif - if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then - ! Set SLight-specific regridding parameters. - call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & - "The nominal thickness of fixed thickness near-surface "//& - "layers with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "SLIGHT_NZ_SURFACE_FIXED", nz_fixed_sfc, & - "The number of fixed-depth surface layers with the SLight "//& - "coordinate.", units="nondimensional", default=2) - call get_param(param_file, mdl, "SLIGHT_SURFACE_AVG_DEPTH", Rho_avg_depth, & - "The thickness of the surface region over which to average "//& - "when calculating the density to use to define the interior "//& - "with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "SLIGHT_NLAY_TO_INTERIOR", nlay_sfc_int, & - "The number of layers to offset the surface density when "//& - "defining where the interior ocean starts with SLight.", & - units="nondimensional", default=2.0) - call get_param(param_file, mdl, "SLIGHT_FIX_HALOCLINES", fix_haloclines, & - "If true, identify regions above the reference pressure "//& - "where the reference pressure systematically underestimates "//& - "the stratification and use this in the definition of the "//& - "interior with the SLight coordinate.", default=.false.) - - call set_regrid_params(CS, dz_min_surface=dz_fixed_sfc, & - nz_fixed_surface=nz_fixed_sfc, Rho_ML_avg_depth=Rho_avg_depth, & - nlay_ML_to_interior=nlay_sfc_int, fix_haloclines=fix_haloclines) - if (fix_haloclines) then - ! Set additional parameters related to SLIGHT_FIX_HALOCLINES. - call get_param(param_file, mdl, "HALOCLINE_FILTER_LENGTH", filt_len, & - "A length scale over which to smooth the temperature and "//& - "salinity before identifying erroneously unstable haloclines.", & - units="m", default=2.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "HALOCLINE_STRAT_TOL", strat_tol, & - "A tolerance for the ratio of the stratification of the "//& - "apparent coordinate stratification to the actual value "//& - "that is used to identify erroneously unstable haloclines. "//& - "This ratio is 1 when they are equal, and sensible values "//& - "are between 0 and 0.5.", units="nondimensional", default=0.2) - call set_regrid_params(CS, halocline_filt_len=filt_len, & - halocline_strat_tol=strat_tol) - endif - - endif - if (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then call get_param(param_file, mdl, "ADAPT_TIME_RATIO", adaptTimeRatio, & "Ratio of ALE timestep to grid timescale.", units="nondim", default=1.0e-1) @@ -718,10 +670,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_max_depths(CS, z_max, GV%m_to_H) elseif (index(trim(string),'FNC1:')==1) then call dz_function1( trim(string(6:)), dz_max ) - if ((coordinateMode(coord_mode) == REGRIDDING_SLIGHT) .and. & - (dz_fixed_sfc > 0.0)) then - do k=1,nz_fixed_sfc ; dz_max(k) = dz_fixed_sfc ; enddo - endif z_max(1) = 0.0 ; do K=1,ke ; z_max(K+1) = z_max(K) + dz_max(K) ; enddo call log_param(param_file, mdl, "!MAXIMUM_INT_DEPTHS", z_max, & trim(message), units=coordinateUnits(coord_mode)) @@ -803,7 +751,6 @@ subroutine end_regridding(CS) if (associated(CS%sigma_CS)) call end_coord_sigma(CS%sigma_CS) if (associated(CS%rho_CS)) call end_coord_rho(CS%rho_CS) if (associated(CS%hycom_CS)) call end_coord_hycom(CS%hycom_CS) - if (associated(CS%slight_CS)) call end_coord_slight(CS%slight_CS) if (associated(CS%adapt_CS)) call end_coord_adapt(CS%adapt_CS) if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS) @@ -877,9 +824,6 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & case ( REGRIDDING_HYBGEN ) call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) - case ( REGRIDDING_SLIGHT ) - call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) - call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) call build_grid_adaptive(G, GV, G%US, h, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -923,7 +867,7 @@ subroutine regridding_preadjust_reqs(CS, do_conv_adj, do_hybgen_unmix, hybgen_CS select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA, REGRIDDING_ARBITRARY, & - REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + REGRIDDING_HYCOM1, REGRIDDING_ADAPTIVE ) do_conv_adj = .false. ; do_hybgen_unmix = .false. case ( REGRIDDING_RHO ) do_conv_adj = .true. ; do_hybgen_unmix = .false. @@ -1671,84 +1615,6 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) enddo ; enddo end subroutine build_grid_adaptive -!> Builds a grid that tracks density interfaces for water that is denser than -!! the surface density plus an increment of some number of layers, and uses all -!! lighter layers uniformly above this location. Note that this amounts to -!! interpolating to find the depth of an arbitrary (non-integer) interface index -!! which should make the results vary smoothly in space to the extent that the -!! surface density and interior stratification vary smoothly in space. Over -!! shallow topography, this will tend to give a uniform sigma-like coordinate. -!! For sufficiently shallow water, a minimum grid spacing is used to avoid -!! certain instabilities. -subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position - - real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] - real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - - ! Local variables - real :: depth ! Depth of the ocean relative to the mean sea surface height in thickness units [H ~> m or kg m-2] - integer :: i, j, k, nz - real :: h_neglect, h_neglect_edge - - if (CS%remap_answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif - - nz = GV%ke - - call assert((GV%ke == CS%nk), "build_grid_SLight is only written to work "//& - "with the same number of input and target layers.") - call assert(CS%target_density_set, "build_grid_SLight : "//& - "Target densities must be set before build_grid_SLight is called.") - - ! Build grid based on target interface densities - do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - if (G%mask2dT(i,j)>0.) then - - depth = (G%bathyT(i,j)+G%Z_ref) * GV%Z_to_H - z_col(1) = 0. ! Work downward rather than bottom up - do K=1,nz - z_col(K+1) = z_col(K) + h(i,j,k) - p_col(k) = tv%P_Ref + CS%compressibility_fraction * & - ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) - enddo - - call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_RZ*GV%g_Earth, & - GV%H_subroundoff, nz, depth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - - ! Calculate the final change in grid position after blending new and old grids - call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) - do K=1,nz+1 ; dzInterface(i,j,K) = -dz_col(K) ; enddo -#ifdef __DO_SAFETY_CHECKS__ - if (dzInterface(i,j,1) /= 0.) stop 'build_grid_SLight: Surface moved?!' - if (dzInterface(i,j,nz+1) /= 0.) stop 'build_grid_SLight: Bottom moved?!' -#endif - - ! This adjusts things robust to round-off errors - call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) - - else ! on land - dzInterface(i,j,:) = 0. - endif ! mask2dT - enddo ; enddo ! i,j - -end subroutine build_grid_SLight - !> Adjust dz_Interface to ensure non-negative future thicknesses subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -2042,7 +1908,7 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) scheme = coordinateMode(coordMode) select case ( scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_ADAPTIVE ) uniformResolution(:) = maxDepth / real(nk) @@ -2085,9 +1951,6 @@ subroutine initCoord(CS, GV, US, coord_mode, param_file) CS%interp_CS) case (REGRIDDING_HYBGEN) call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file) - case (REGRIDDING_SLIGHT) - call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & - CS%interp_CS, GV%m_to_H) case (REGRIDDING_ADAPTIVE) call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H, US%kg_m3_to_R) end select @@ -2181,8 +2044,6 @@ subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) select case (CS%regridding_scheme) case (REGRIDDING_HYCOM1) call set_hycom_params(CS%hycom_CS, max_interface_depths=CS%max_interface_depths) - case (REGRIDDING_SLIGHT) - call set_slight_params(CS%slight_CS, max_interface_depths=CS%max_interface_depths) end select end subroutine set_regrid_max_depths @@ -2207,8 +2068,6 @@ subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) select case (CS%regridding_scheme) case (REGRIDDING_HYCOM1) call set_hycom_params(CS%hycom_CS, max_layer_thickness=CS%max_layer_thickness) - case (REGRIDDING_SLIGHT) - call set_slight_params(CS%slight_CS, max_layer_thickness=CS%max_layer_thickness) end select end subroutine set_regrid_max_thickness @@ -2320,7 +2179,7 @@ function getCoordinateUnits( CS ) character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & REGRIDDING_ADAPTIVE ) getCoordinateUnits = 'meter' case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) @@ -2361,8 +2220,6 @@ function getCoordinateShortName( CS ) getCoordinateShortName = 'z-rho' case ( REGRIDDING_HYBGEN ) getCoordinateShortName = 'hybrid' - case ( REGRIDDING_SLIGHT ) - getCoordinateShortName = 's-rho' case ( REGRIDDING_ADAPTIVE ) getCoordinateShortName = 'adaptive' case default @@ -2375,8 +2232,7 @@ end function getCoordinateShortName !> Can be used to set any of the parameters for MOM_regridding. subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_grid_weight, & interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & - compress_fraction, ref_pressure, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & - nlay_ML_to_interior, fix_haloclines, halocline_filt_len, halocline_strat_tol, & + compress_fraction, ref_pressure, & integrate_downward_for_e, remap_answers_2018, remap_answer_date, & adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) type(regridding_CS), intent(inout) :: CS !< Regridding control structure @@ -2390,18 +2246,6 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density [nondim] real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent !! coordinates [R L2 T-2 ~> Pa] - real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost - !! SLight_nkml_min layers [H ~> m or kg m-2] - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model - real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential - !! density [H ~> m or kg m-2] - real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find - !! resolved stratification [nondim] - logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate - real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for - !! spuriously unstable water mass profiles [H ~> m or kg m-2] - real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic - !! halocline region. logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward !! from the top. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions @@ -2466,18 +2310,6 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS) case (REGRIDDING_HYBGEN) ! Do nothing for now. - case (REGRIDDING_SLIGHT) - if (present(min_thickness)) call set_slight_params(CS%slight_CS, min_thickness=min_thickness) - if (present(dz_min_surface)) call set_slight_params(CS%slight_CS, dz_ml_min=dz_min_surface) - if (present(nz_fixed_surface)) call set_slight_params(CS%slight_CS, nz_fixed_surface=nz_fixed_surface) - if (present(Rho_ML_avg_depth)) call set_slight_params(CS%slight_CS, Rho_ML_avg_depth=Rho_ML_avg_depth) - if (present(nlay_ML_to_interior)) call set_slight_params(CS%slight_CS, nlay_ML_offset=nlay_ML_to_interior) - if (present(fix_haloclines)) call set_slight_params(CS%slight_CS, fix_haloclines=fix_haloclines) - if (present(halocline_filt_len)) call set_slight_params(CS%slight_CS, halocline_filter_length=halocline_filt_len) - if (present(halocline_strat_tol)) call set_slight_params(CS%slight_CS, halocline_strat_tol=halocline_strat_tol) - if (present(compress_fraction)) call set_slight_params(CS%slight_CS, compressibility_fraction=compress_fraction) - if (associated(CS%slight_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & - call set_slight_params(CS%slight_CS, interp_CS=CS%interp_CS) case (REGRIDDING_ADAPTIVE) if (present(adaptTimeRatio)) call set_adapt_params(CS%adapt_CS, adaptTimeRatio=adaptTimeRatio) if (present(adaptZoom)) call set_adapt_params(CS%adapt_CS, adaptZoom=adaptZoom) @@ -2535,7 +2367,7 @@ function getStaticThickness( CS, SSH, depth ) select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & - REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + REGRIDDING_ADAPTIVE ) if (depth>0.) then z = ssh do k = 1, CS%nk diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 deleted file mode 100644 index 4b4ac8a153..0000000000 --- a/src/ALE/coord_slight.F90 +++ /dev/null @@ -1,733 +0,0 @@ -!> Regrid columns for the SLight coordinate -module coord_slight - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL -use MOM_EOS, only : EOS_type, calculate_compress -use MOM_EOS, only : calculate_density, calculate_density_derivs -use regrid_interp, only : interp_CS_type, regridding_set_ppolys -use regrid_interp, only : NR_ITERATIONS, NR_TOLERANCE, DEGREE_MAX - -implicit none ; private - -!> Control structure containing required parameters for the SLight coordinate -type, public :: slight_CS ; private - - !> Number of layers/levels - integer :: nk - - !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2] - real :: min_thickness - - !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] - real :: ref_pressure - - !> Fraction (between 0 and 1) of compressibility to add to potential density - !! profiles when interpolating for target grid positions. [nondim] - real :: compressibility_fraction - - ! The following 4 parameters were introduced for use with the SLight coordinate: - !> Depth over which to average to determine the mixed layer potential density [H ~> m or kg m-2] - real :: Rho_ML_avg_depth - - !> Number of layers to offset the mixed layer density to find resolved stratification [nondim] - real :: nlay_ml_offset - - !> The number of fixed-thickness layers at the top of the model - integer :: nz_fixed_surface = 2 - - !> The fixed resolution in the topmost SLight_nkml_min layers [H ~> m or kg m-2] - real :: dz_ml_min - - !> If true, detect regions with much weaker stratification in the coordinate - !! than based on in-situ density, and use a stretched coordinate there. - logical :: fix_haloclines = .false. - - !> A length scale over which to filter T & S when looking for spuriously - !! unstable water mass profiles [H ~> m or kg m-2]. - real :: halocline_filter_length - - !> A value of the stratification ratio that defines a problematic halocline region [nondim]. - real :: halocline_strat_tol - - !> Nominal density of interfaces [R ~> kg m-3]. - real, allocatable, dimension(:) :: target_density - - !> Maximum depths of interfaces [H ~> m or kg m-2]. - real, allocatable, dimension(:) :: max_interface_depths - - !> Maximum thicknesses of layers [H ~> m or kg m-2]. - real, allocatable, dimension(:) :: max_layer_thickness - - !> Interpolation control structure - type(interp_CS_type) :: interp_CS -end type slight_CS - -public init_coord_slight, set_slight_params, build_slight_column, end_coord_slight - -contains - -!> Initialise a slight_CS with pointers to parameters -subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H) - type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk !< Number of layers in the grid - real, intent(in) :: ref_pressure !< Coordinate reference pressure [R L2 T-2 ~> Pa] - real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] - type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation - real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - - real :: m_to_H_rescale ! A unit conversion factor. - - if (associated(CS)) call MOM_error(FATAL, "init_coord_slight: CS already associated!") - allocate(CS) - allocate(CS%target_density(nk+1)) - - m_to_H_rescale = 1.0 ; if (present(m_to_H)) m_to_H_rescale = m_to_H - - CS%nk = nk - CS%ref_pressure = ref_pressure - CS%target_density(:) = target_density(:) - CS%interp_CS = interp_CS - - ! Set real parameter default values - CS%compressibility_fraction = 0. ! Nondim. - CS%Rho_ML_avg_depth = 1.0 * m_to_H_rescale - CS%nlay_ml_offset = 2.0 ! Nondim. - CS%dz_ml_min = 1.0 * m_to_H_rescale - CS%halocline_filter_length = 2.0 * m_to_H_rescale - CS%halocline_strat_tol = 0.25 ! Nondim. - -end subroutine init_coord_slight - -!> This subroutine deallocates memory in the control structure for the coord_slight module -subroutine end_coord_slight(CS) - type(slight_CS), pointer :: CS !< Coordinate control structure - - ! nothing to do - if (.not. associated(CS)) return - deallocate(CS%target_density) - deallocate(CS) -end subroutine end_coord_slight - -!> This subroutine can be used to set the parameters for the coord_slight module -subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & - min_thickness, compressibility_fraction, dz_ml_min, & - nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & - halocline_filter_length, halocline_strat_tol, interp_CS) - type(slight_CS), pointer :: CS !< Coordinate control structure - real, dimension(:), & - optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] - real, dimension(:), & - optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] - real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the - !! new grid through regridding [H ~> m or kg m-2] - real, optional, intent(in) :: compressibility_fraction !< Fraction (between 0 and 1) of - !! compressibility to add to potential density profiles when - !! interpolating for target grid positions. [nondim] - real, optional, intent(in) :: dz_ml_min !< The fixed resolution in the topmost - !! SLight_nkml_min layers [H ~> m or kg m-2] - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the - !! top of the model - real, optional, intent(in) :: Rho_ML_avg_depth !< Depth over which to average to determine - !! the mixed layer potential density [H ~> m or kg m-2] - real, optional, intent(in) :: nlay_ML_offset !< Number of layers to offset the mixed layer - !! density to find resolved stratification [nondim] - logical, optional, intent(in) :: fix_haloclines !< If true, detect regions with much weaker than - !! based on in-situ density, and use a stretched coordinate there. - real, optional, intent(in) :: halocline_filter_length !< A length scale over which to filter T & S - !! when looking for spuriously unstable water mass profiles [H ~> m or kg m-2]. - real, optional, intent(in) :: halocline_strat_tol !< A value of the stratification ratio that - !! defines a problematic halocline region [nondim]. - type(interp_CS_type), & - optional, intent(in) :: interp_CS !< Controls for interpolation - - if (.not. associated(CS)) call MOM_error(FATAL, "set_slight_params: CS not associated") - - if (present(max_interface_depths)) then - if (size(max_interface_depths) /= CS%nk+1) & - call MOM_error(FATAL, "set_slight_params: max_interface_depths inconsistent size") - allocate(CS%max_interface_depths(CS%nk+1)) - CS%max_interface_depths(:) = max_interface_depths(:) - endif - - if (present(max_layer_thickness)) then - if (size(max_layer_thickness) /= CS%nk) & - call MOM_error(FATAL, "set_slight_params: max_layer_thickness inconsistent size") - allocate(CS%max_layer_thickness(CS%nk)) - CS%max_layer_thickness(:) = max_layer_thickness(:) - endif - - if (present(min_thickness)) CS%min_thickness = min_thickness - if (present(compressibility_fraction)) CS%compressibility_fraction = compressibility_fraction - - if (present(dz_ml_min)) CS%dz_ml_min = dz_ml_min - if (present(nz_fixed_surface)) CS%nz_fixed_surface = nz_fixed_surface - if (present(Rho_ML_avg_depth)) CS%Rho_ML_avg_depth = Rho_ML_avg_depth - if (present(nlay_ML_offset)) CS%nlay_ML_offset = nlay_ML_offset - if (present(fix_haloclines)) CS%fix_haloclines = fix_haloclines - if (present(halocline_filter_length)) CS%halocline_filter_length = halocline_filter_length - if (present(halocline_strat_tol)) then - if (halocline_strat_tol > 1.0) call MOM_error(FATAL, "set_slight_params: "//& - "HALOCLINE_STRAT_TOL must not exceed 1.0.") - CS%halocline_strat_tol = halocline_strat_tol - endif - - if (present(interp_CS)) CS%interp_CS = interp_CS -end subroutine set_slight_params - -!> Build a SLight coordinate column -subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & - nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & - h_neglect, h_neglect_edge) - type(slight_CS), intent(in) :: CS !< Coordinate control structure - type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure - real, intent(in) :: H_to_pres !< A conversion factor from thicknesses to - !! scaled pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] - real, intent(in) :: H_subroundoff !< GV%H_subroundoff - integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) - real, dimension(nz), intent(in) :: T_col !< T for column [C ~> degC] - real, dimension(nz), intent(in) :: S_col !< S for column [S ~> ppt] - real, dimension(nz), intent(in) :: h_col !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: p_col !< Layer center pressure [R L2 T-2 ~> Pa] - real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of - !! cell reconstructions [H ~> m or kg m-2]. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose - !! of edge value calculations [H ~> m or kg m-2]. - ! Local variables - real, dimension(nz) :: rho_col ! Layer densities [R ~> kg m-3] - real, dimension(nz) :: T_f, S_f ! Filtered layer temperature [C ~> degC] and salinity [S ~> ppt] - logical, dimension(nz+1) :: reliable ! If true, this interface is in a reliable position. - real, dimension(nz+1) :: T_int, S_int ! Temperature [C ~> degC] and salinity [S ~> ppt] interpolated to interfaces. - real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] - real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [T2 L-2 ~> kg m-3 Pa-1] - real, dimension(nz+1) :: p_IS, p_R ! Pressures [R L2 T-2 ~> Pa] - real, dimension(nz+1) :: drhoIS_dT ! The partial derivative of in situ density with temperature - ! in [R C-1 ~> kg m-3 degC-1] - real, dimension(nz+1) :: drhoIS_dS ! The partial derivative of in situ density with salinity - ! in [R S-1 ~> kg m-3 ppt-1] - real, dimension(nz+1) :: drhoR_dT ! The partial derivative of reference density with temperature - ! in [R C-1 ~> kg m-3 degC-1] - real, dimension(nz+1) :: drhoR_dS ! The partial derivative of reference density with salinity - ! in [R S-1 ~> kg m-3 ppt-1] - real, dimension(nz+1) :: strat_rat - real :: H_to_cPa ! A conversion factor from thicknesses to the compressibility fraction times - ! the units of pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] - real :: drIS, drR ! In situ and reference density differences [R ~> kg m-3] - real :: Fn_now, I_HStol, Fn_zero_val ! Nondimensional variables [nondim] - real :: z_int_unst ! The depth where the stratification allows the interior grid to start [H ~> m or kg m-2] - real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. - real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. - real :: wgt, cowgt ! A weight and its complement [nondim]. - real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. - real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. - real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. - real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. - real :: k_interior ! The (real) value of k where the interior grid starts [nondim]. - real :: k_int2 ! The (real) value of k where the interior grid starts [nondim]. - real :: z_interior ! The depth where the interior grid starts [H ~> m or kg m-2]. - real :: z_ml_fix ! The depth at which the fixed-thickness near-surface layers end [H ~> m or kg m-2]. - real :: dz_dk ! The thickness of layers between the fixed-thickness - ! near-surface layars and the interior [H ~> m or kg m-2]. - real :: Lfilt ! A filtering lengthscale [H ~> m or kg m-2]. - logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. - logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. - real :: h_tr, b_denom_1, b1, d1 ! Temporary variables used by the tridiagonal solver. - real, dimension(nz) :: c1 ! Temporary variables used by the tridiagonal solver. - integer :: kur1, kur2 ! The indicies at the top and bottom of an unreliable region. - integer :: kur_ss ! The index to start with in the search for the next unstable region. - integer :: k, nkml - - maximum_depths_set = allocated(CS%max_interface_depths) - maximum_h_set = allocated(CS%max_layer_thickness) - - if (z_col(nz+1) - z_col(1) < nz*CS%min_thickness) then - ! This is a nearly massless total depth, so distribute the water evenly. - dz = (z_col(nz+1) - z_col(1)) / real(nz) - do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo - else - call calculate_density(T_col, S_col, p_col, rho_col, eqn_of_state) - - ! Find the locations of the target potential densities, flagging - ! locations in apparently unstable regions as not reliable. - call rho_interfaces_col(rho_col, h_col, z_col, CS%target_density, nz, & - z_col_new, CS, reliable, debug=.true., & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - - ! Ensure that the interfaces are at least CS%min_thickness apart. - if (CS%min_thickness > 0.0) then - ! Move down interfaces below overly thin layers. - do K=2,nz ; if (z_col_new(K) < z_col_new(K-1) + CS%min_thickness) then - z_col_new(K) = z_col_new(K-1) + CS%min_thickness - endif ; enddo - ! Now move up any interfaces that are too close to the bottom. - do K=nz,2,-1 ; if (z_col_new(K) > z_col_new(K+1) - CS%min_thickness) then - z_col_new(K) = z_col_new(K+1) - CS%min_thickness - else - exit ! No more interfaces can be too close to the bottom. - endif ; enddo - endif - - ! Fix up the unreliable regions. - kur_ss = 2 ! reliable(1) and reliable(nz+1) must always be true. - do - ! Search for the uppermost unreliable interface postion. - kur1 = nz+2 - do K=kur_ss,nz ; if (.not.reliable(K)) then - kur1 = K ; exit - endif ; enddo - if (kur1 > nz) exit ! Everything is now reliable. - - kur2 = kur1-1 ! For error checking. - do K=kur1+1,nz+1 ; if (reliable(K)) then - kur2 = K-1 ; kur_ss = K ; exit - endif ; enddo - if (kur2 < kur1) call MOM_error(FATAL, "Bad unreliable range.") - - dz_ur = z_col_new(kur2+1) - z_col_new(kur1-1) - ! drho = CS%target_density(kur2+1) - CS%target_density(kur1-1) - ! Perhaps reset the wgt and cowgt depending on how bad the old interface - ! locations were. - wgt = 1.0 ; cowgt = 0.0 ! = 1.0-wgt - do K=kur1,kur2 - z_col_new(K) = cowgt*z_col_new(K) + & - wgt * (z_col_new(kur1-1) + dz_ur*(K - (kur1-1)) / ((kur2 - kur1) + 2)) - enddo - enddo - - ! Determine which interfaces are in the s-space region and the depth extent - ! of this region. - z_wt = 0.0 ; rho_x_z = 0.0 - H_ml_av = CS%Rho_ml_avg_depth - do k=1,nz - if (z_wt + h_col(k) >= H_ml_av) then - rho_x_z = rho_x_z + rho_col(k) * (H_ml_av - z_wt) - z_wt = H_ml_av - exit - else - rho_x_z = rho_x_z + rho_col(k) * h_col(k) - z_wt = z_wt + h_col(k) - endif - enddo - if (z_wt > 0.0) rho_ml_av = rho_x_z / z_wt - - nkml = CS%nz_fixed_surface - ! Find the interface that matches rho_ml_av. - if (rho_ml_av <= CS%target_density(nkml)) then - k_interior = CS%nlay_ml_offset + real(nkml) - elseif (rho_ml_av > CS%target_density(nz+1)) then - k_interior = real(nz+1) - else ; do K=nkml,nz - if ((rho_ml_av >= CS%target_density(K)) .and. & - (rho_ml_av < CS%target_density(K+1))) then - k_interior = (CS%nlay_ml_offset + K) + & - (rho_ml_av - CS%target_density(K)) / & - (CS%target_density(K+1) - CS%target_density(K)) - exit - endif - enddo ; endif - if (k_interior > real(nz+1)) k_interior = real(nz+1) - - ! Linearly interpolate to find z_interior. This could be made more sophisticated. - K = int(ceiling(k_interior)) - z_interior = (K-k_interior)*z_col_new(K-1) + (1.0+(k_interior-K))*z_col_new(K) - - if (CS%fix_haloclines) then - ! ! Identify regions above the reference pressure where the chosen - ! ! potential density significantly underestimates the actual - ! ! stratification, and use these to find a second estimate of - ! ! z_int_unst and k_interior. - - if (CS%halocline_filter_length > 0.0) then - Lfilt = CS%halocline_filter_length - - ! Filter the temperature and salnity with a fixed lengthscale. - h_tr = h_col(1) + H_subroundoff - b1 = 1.0 / (h_tr + Lfilt) ; d1 = h_tr * b1 - T_f(1) = (b1*h_tr)*T_col(1) ; S_f(1) = (b1*h_tr)*S_col(1) - do k=2,nz - c1(k) = Lfilt * b1 - h_tr = h_col(k) + H_subroundoff ; b_denom_1 = h_tr + d1*Lfilt - b1 = 1.0 / (b_denom_1 + Lfilt) ; d1 = b_denom_1 * b1 - T_f(k) = b1 * (h_tr*T_col(k) + Lfilt*T_f(k-1)) - S_f(k) = b1 * (h_tr*S_col(k) + Lfilt*S_f(k-1)) - enddo - do k=nz-1,1,-1 - T_f(k) = T_f(k) + c1(k+1)*T_f(k+1) ; S_f(k) = S_f(k) + c1(k+1)*S_f(k+1) - enddo - else - do k=1,nz ; T_f(k) = T_col(k) ; S_f(k) = S_col(k) ; enddo - endif - - T_int(1) = T_f(1) ; S_int(1) = S_f(1) - do K=2,nz - T_int(K) = 0.5*(T_f(k-1) + T_f(k)) ; S_int(K) = 0.5*(S_f(k-1) + S_f(k)) - p_IS(K) = z_col(K) * H_to_pres - p_R(K) = CS%ref_pressure + CS%compressibility_fraction * ( p_IS(K) - CS%ref_pressure ) - enddo - T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) - p_IS(nz+1) = z_col(nz+1) * H_to_pres - call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, & - eqn_of_state, (/2,nz/) ) - call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, & - eqn_of_state, (/2,nz/) ) - if (CS%compressibility_fraction > 0.0) then - call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, eqn_of_state, (/2,nz/)) - else - do K=2,nz ; drho_dp(K) = 0.0 ; enddo - endif - - H_to_cPa = CS%compressibility_fraction * H_to_pres - strat_rat(1) = 1.0 - do K=2,nz - drIS = drhoIS_dT(K) * (T_f(k) - T_f(k-1)) + & - drhoIS_dS(K) * (S_f(k) - S_f(k-1)) - drR = (drhoR_dT(K) * (T_f(k) - T_f(k-1)) + & - drhoR_dS(K) * (S_f(k) - S_f(k-1))) + & - drho_dp(K) * (H_to_cPa*0.5*(h_col(k) + h_col(k-1))) - - if (drIS <= 0.0) then - strat_rat(K) = 2.0 ! Maybe do this? => ; if (drR < 0.0) strat_rat(K) = -2.0 - else - strat_rat(K) = 2.0*max(drR,0.0) / (drIS + abs(drR)) - endif - enddo - strat_rat(nz+1) = 1.0 - - z_int_unst = 0.0 ; Fn_now = 0.0 - Fn_zero_val = min(2.0*CS%halocline_strat_tol, & - 0.5*(1.0 + CS%halocline_strat_tol)) - if (CS%halocline_strat_tol > 0.0) then - ! Use Adcroft's reciprocal rule. - I_HStol = 0.0 ; if (Fn_zero_val - CS%halocline_strat_tol > 0.0) & - I_HStol = 1.0 / (Fn_zero_val - CS%halocline_strat_tol) - do k=nz,1,-1 ; if (CS%ref_pressure > p_IS(k+1)) then - z_int_unst = z_int_unst + Fn_now * h_col(k) - if (strat_rat(K) <= Fn_zero_val) then - if (strat_rat(K) <= CS%halocline_strat_tol) then ; Fn_now = 1.0 - else - Fn_now = max(Fn_now, (Fn_zero_val - strat_rat(K)) * I_HStol) - endif - endif - endif ; enddo - else - do k=nz,1,-1 ; if (CS%ref_pressure > p_IS(k+1)) then - z_int_unst = z_int_unst + Fn_now * h_col(k) - if (strat_rat(K) <= CS%halocline_strat_tol) Fn_now = 1.0 - endif ; enddo - endif - - if (z_interior < z_int_unst) then - ! Find a second estimate of the extent of the s-coordinate region. - kur1 = max(int(ceiling(k_interior)),2) - if (z_col_new(kur1-1) < z_interior) then - k_int2 = kur1 - do K = kur1,nz+1 ; if (z_col_new(K) >= z_int_unst) then - ! This is linear interpolation again. - if (z_col_new(K-1) >= z_int_unst) & - call MOM_error(FATAL,"build_grid_SLight, bad halocline structure.") - k_int2 = real(K-1) + (z_int_unst - z_col_new(K-1)) / & - (z_col_new(K) - z_col_new(K-1)) - exit - endif ; enddo - if (z_col_new(nz+1) < z_int_unst) then - ! This should be unnecessary. - z_int_unst = z_col_new(nz+1) ; k_int2 = real(nz+1) - endif - - ! Now take the larger values. - if (k_int2 > k_interior) then - k_interior = k_int2 ; z_interior = z_int_unst - endif - endif - endif - endif ! fix_haloclines - - z_col_new(1) = 0.0 - do K=2,nkml+1 - z_col_new(K) = min((K-1)*CS%dz_ml_min, & - z_col_new(nz+1) - CS%min_thickness*(nz+1-K)) - enddo - z_ml_fix = z_col_new(nkml+1) - if (z_interior > z_ml_fix) then - dz_dk = (z_interior - z_ml_fix) / (k_interior - (nkml+1)) - do K=nkml+2,int(floor(k_interior)) - z_col_new(K) = z_ml_fix + dz_dk * (K - (nkml+1)) - enddo - else ! The fixed-thickness z-region penetrates into the interior. - do K=nkml+2,nz - if (z_col_new(K) <= z_col_new(CS%nz_fixed_surface+1)) then - z_col_new(K) = z_col_new(CS%nz_fixed_surface+1) - else ; exit ; endif - enddo - endif - - if (maximum_depths_set .and. maximum_h_set) then ; do k=2,nz - ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. - ! Recall that z_col_new is positive downward. - z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K), & - z_col_new(K-1) + CS%max_layer_thickness(k-1)) - enddo ; elseif (maximum_depths_set) then ; do K=2,nz - z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K)) - enddo ; elseif (maximum_h_set) then ; do k=2,nz - z_col_new(K) = min(z_col_new(K), z_col_new(K-1) + CS%max_layer_thickness(k-1)) - enddo ; endif - - endif ! Total thickness exceeds nz*CS%min_thickness. - -end subroutine build_slight_column - -!> Finds the new interface locations in a column of water that match the -!! prescribed target densities. -subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & - CS, reliable, debug, h_neglect, h_neglect_edge) - integer, intent(in) :: nz !< Number of layers - real, dimension(nz), intent(in) :: rho_col !< Initial layer reference densities [R ~> kg m-3]. - real, dimension(nz), intent(in) :: h_col !< Initial layer thicknesses [H ~> m or kg m-2]. - real, dimension(nz+1), intent(in) :: z_col !< Initial interface heights [H ~> m or kg m-2]. - real, dimension(nz+1), intent(in) :: rho_tgt !< Interface target densities. - real, dimension(nz+1), intent(inout) :: z_col_new !< New interface heights [H ~> m or kg m-2]. - type(slight_CS), intent(in) :: CS !< Coordinate control structure - logical, dimension(nz+1), intent(inout) :: reliable !< If true, the interface positions - !! are well defined from a stable region. - logical, optional, intent(in) :: debug !< If present and true, do debugging checks. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of - !! cell reconstructions [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose - !! of edge value calculations [H ~> m or kg m-2] - - real, dimension(nz+1) :: ru_max_int ! The maximum and minimum densities in - real, dimension(nz+1) :: ru_min_int ! an unstable region around an interface [R ~> kg m-3]. - real, dimension(nz) :: ru_max_lay ! The maximum and minimum densities in - real, dimension(nz) :: ru_min_lay ! an unstable region containing a layer [R ~> kg m-3]. - real, dimension(nz,2) :: ppoly_i_E ! Edge value of polynomial [R ~> kg m-3] - real, dimension(nz,2) :: ppoly_i_S ! Edge slope of polynomial [R H-1 ~> kg m-4 or m-1] - real, dimension(nz,DEGREE_MAX+1) :: ppoly_i_coefficients ! Coefficients of polynomial [R ~> kg m-3] - logical, dimension(nz) :: unstable_lay ! If true, this layer is in an unstable region. - logical, dimension(nz+1) :: unstable_int ! If true, this interface is in an unstable region. - real :: rt ! The current target density [R ~> kg m-3]. - real :: zf ! The fractional z-position within a layer of the target density [nondim]. - real :: rfn ! The target density relative to the interpolated density [R ~> kg m-3] - real :: a(5) ! Coefficients of a local polynomial minus the target density [R ~> kg m-3]. - real :: zf1, zf2 ! Two previous estimates of zf [nondim] - real :: rfn1, rfn2 ! Values of rfn at zf1 and zf2 [R ~> kg m-3] - real :: drfn_dzf ! The partial derivative of rfn with zf [R ~> kg m-3] - real :: sgn, delta_zf, zf_prev ! [nondim] - real :: tol ! The tolerance for convergence of zf [nondim] - logical :: k_found ! If true, the position has been found. - integer :: k_layer ! The index of the stable layer containing an interface. - integer :: ppoly_degree - integer :: k, k1, k1_min, itt, max_itt, m - - real :: z_sgn ! 1 or -1, depending on whether z increases with increasing K. - logical :: debugging - - debugging = .false. ; if (present(debug)) debugging = debug - max_itt = NR_ITERATIONS - tol = NR_TOLERANCE - - z_sgn = 1.0 ; if ( z_col(1) > z_col(nz+1) ) z_sgn = -1.0 - if (debugging) then - do K=1,nz - if (abs((z_col(K+1) - z_col(K)) - z_sgn*h_col(k)) > & - 1.0e-14*(abs(z_col(K+1)) + abs(z_col(K)) + abs(h_col(k))) ) & - call MOM_error(FATAL, "rho_interfaces_col: Inconsistent z_col and h_col") - enddo - endif - - if ( z_col(1) == z_col(nz+1) ) then - ! This is a massless column! - do K=1,nz+1 ; z_col_new(K) = z_col(1) ; reliable(K) = .true. ; enddo - return - endif - - ! This sets up the piecewise polynomials based on the rho_col profile. - call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h_col, ppoly_i_E, ppoly_i_S, & - ppoly_i_coefficients, ppoly_degree, h_neglect, h_neglect_edge) - - ! Determine the density ranges of unstably stratified segments. - ! Interfaces that start out in an unstably stratified segment can - ! only escape if they are outside of the bounds of that segment, and no - ! interfaces are ever mapped into an unstable segment. - unstable_int(1) = .false. - ru_max_int(1) = ppoly_i_E(1,1) - - unstable_lay(1) = (ppoly_i_E(1,1) > ppoly_i_E(1,2)) - ru_max_lay(1) = max(ppoly_i_E(1,1), ppoly_i_E(1,2)) - - do K=2,nz - unstable_int(K) = (ppoly_i_E(k-1,2) > ppoly_i_E(k,1)) - ru_max_int(K) = max(ppoly_i_E(k-1,2), ppoly_i_E(k,1)) - ru_min_int(K) = min(ppoly_i_E(k-1,2), ppoly_i_E(k,1)) - if (unstable_int(K) .and. unstable_lay(k-1)) & - ru_max_int(K) = max(ru_max_lay(k-1), ru_max_int(K)) - - unstable_lay(k) = (ppoly_i_E(k,1) > ppoly_i_E(k,2)) - ru_max_lay(k) = max(ppoly_i_E(k,1), ppoly_i_E(k,2)) - ru_min_lay(k) = min(ppoly_i_E(k,1), ppoly_i_E(k,2)) - if (unstable_lay(k) .and. unstable_int(K)) & - ru_max_lay(k) = max(ru_max_int(K), ru_max_lay(k)) - enddo - unstable_int(nz+1) = .false. - ru_min_int(nz+1) = ppoly_i_E(nz,2) - - do K=nz,1,-1 - if (unstable_lay(k) .and. unstable_int(K+1)) & - ru_min_lay(k) = min(ru_min_int(K+1), ru_min_lay(k)) - - if (unstable_int(K) .and. unstable_lay(k)) & - ru_min_int(K) = min(ru_min_lay(k), ru_min_int(K)) - enddo - - z_col_new(1) = z_col(1) ; reliable(1) = .true. - k1_min = 1 - do K=2,nz ! Find the locations of the various target densities for the interfaces. - rt = rho_tgt(K) - k_layer = -1 - k_found = .false. - - ! Many light layers are found at the top, so start there. - if (rt <= ppoly_i_E(k1_min,1)) then - z_col_new(K) = z_col(k1_min) - k_found = .true. - ! Do not change k1_min for the next layer. - elseif (k1_min == nz+1) then - z_col_new(K) = z_col(nz+1) - else - ! Start with the previous location and search outward. - if (unstable_int(K) .and. (rt >= ru_min_int(K)) .and. (rt <= ru_max_int(K))) then - ! This interface started in an unstable region and should not move due to remapping. - z_col_new(K) = z_col(K) ; reliable(K) = .false. - k1_min = K ; k_found = .true. - elseif ((rt >= ppoly_i_E(k-1,2)) .and. (rt <= ppoly_i_E(k,1))) then - ! This interface is already in the right place and does not move. - z_col_new(K) = z_col(K) ; reliable(K) = .true. - k1_min = K ; k_found = .true. - elseif (rt < ppoly_i_E(k-1,2)) then ! Search upward - do k1=K-1,k1_min,-1 - ! Check whether rt is in layer k. - if ((rt < ppoly_i_E(k1,2)) .and. (rt > ppoly_i_E(k1,1))) then - ! rt is in layer k. - k_layer = k1 - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_lay(k1) .and. (rt >= ru_min_lay(k1)) .and. (rt <= ru_max_lay(K1))) then - ! rt would be found at unstable layer that it can not penetrate. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1+1) ; reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif - ! Check whether rt is at interface K. - if (k1 > 1) then ; if ((rt <= ppoly_i_E(k1,1)) .and. (rt >= ppoly_i_E(k1-1,2))) then - ! rt is at interface K1 - z_col_new(K) = z_col(K1) ; reliable(K) = .true. - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_int(K1) .and. (rt >= ru_min_int(k1)) .and. (rt <= ru_max_int(K1))) then - ! rt would be found at an unstable interface that it can not pass. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1) ; reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif ; endif - enddo - - if (.not.k_found) then - ! This should not happen unless k1_min = 1. - if (k1_min < 2) then - z_col_new(K) = z_col(k1_min) - else - z_col_new(K) = z_col(k1_min) - endif - endif - - else ! Search downward - do k1=K,nz - if ((rt < ppoly_i_E(k1,2)) .and. (rt > ppoly_i_E(k1,1))) then - ! rt is in layer k. - k_layer = k1 - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_lay(k1) .and. (rt >= ru_min_lay(k1)) .and. (rt <= ru_max_lay(K1))) then - ! rt would be found at unstable layer that it can not penetrate. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1) - reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif - if (k1 < nz) then ; if ((rt <= ppoly_i_E(k1+1,1)) .and. (rt >= ppoly_i_E(k1,2))) then - ! rt is at interface K1+1 - - z_col_new(K) = z_col(K1+1) ; reliable(K) = .true. - k1_min = k1+1 ; k_found = .true. ; exit - elseif (unstable_int(K1+1) .and. (rt >= ru_min_int(k1+1)) .and. (rt <= ru_max_int(K1+1))) then - ! rt would be found at an unstable interface that it can not pass. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1+1) - reliable(K) = .false. - k1_min = k1+1 ; k_found = .true. ; exit - endif ; endif - enddo - if (.not.k_found) then - z_col_new(K) = z_col(nz+1) - if (rt >= ppoly_i_E(nz,2)) then - reliable(K) = .true. - else - reliable(K) = .false. - endif - endif - endif - - if (k_layer > 0) then ! The new location is inside of layer k_layer. - ! Note that this is coded assuming that this layer is stably stratified. - if (.not.(ppoly_i_E(k1,2) > ppoly_i_E(k1,1))) call MOM_error(FATAL, & - "build_grid_SLight: Erroneously searching for an interface in an unstratified layer.") - - ! Use the false position method to find the location (degree <= 1) or the first guess. - zf = (rt - ppoly_i_E(k1,1)) / (ppoly_i_E(k1,2) - ppoly_i_E(k1,1)) - - if (ppoly_degree > 1) then ! Iterate to find the solution. - a(:) = 0.0 ; a(1) = ppoly_i_coefficients(k_layer,1) - rt - do m=2,ppoly_degree+1 ; a(m) = ppoly_i_coefficients(k_layer,m) ; enddo - ! Bracket the root. - zf1 = 0.0 ; rfn1 = a(1) - zf2 = 1.0 ; rfn2 = a(1) + (a(2) + (a(3) + (a(4) + a(5)))) - if (rfn1 * rfn2 > 0.0) call MOM_error(FATAL, "build_grid_SLight: Bad bracketing.") - - do itt=1,max_itt - rfn = a(1) + zf*(a(2) + zf*(a(3) + zf*(a(4) + zf*a(5)))) - ! Reset one of the ends of the bracket. - if (rfn * rfn1 > 0.0) then - zf1 = zf ; rfn1 = rfn - else - zf2 = zf ; rfn2 = rfn - endif - if (rfn1 == rfn2) exit - - drfn_dzf = (a(2) + zf*(2.0*a(3) + zf*(3.0*a(4) + zf*4.0*a(5)))) - sgn = 1.0 ; if (drfn_dzf < 0.0) sgn = -1.0 - - if ((sgn*(zf - rfn) >= zf1 * abs(drfn_dzf)) .and. & - (sgn*(zf - rfn) <= zf2 * abs(drfn_dzf))) then - delta_zf = -rfn / drfn_dzf - zf = zf + delta_zf - else ! Newton's method goes out of bounds, so use a false position method estimate - zf_prev = zf - zf = ( rfn2 * zf1 - rfn1 * zf2 ) / (rfn2 - rfn1) - delta_zf = zf - zf_prev - endif - - if (abs(delta_zf) < tol) exit - enddo - endif - z_col_new(K) = z_col(k_layer) + zf * z_sgn * h_col(k_layer) - reliable(K) = .true. - endif - - endif - - enddo - z_col_new(nz+1) = z_col(nz+1) ; reliable(nz+1) = .true. - -end subroutine rho_interfaces_col - -end module coord_slight diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90 index 9fe638dd5b..0c5ccf268f 100644 --- a/src/ALE/regrid_consts.F90 +++ b/src/ALE/regrid_consts.F90 @@ -16,8 +16,6 @@ module regrid_consts integer, parameter :: REGRIDDING_SIGMA = 4 !< Sigma coordinates identifier integer, parameter :: REGRIDDING_ARBITRARY = 5 !< Arbitrary coordinates identifier integer, parameter :: REGRIDDING_HYCOM1 = 6 !< Simple HyCOM coordinates without BBL -integer, parameter :: REGRIDDING_SLIGHT = 7 !< Identifier for stretched coordinates in the - !! lightest water, isopycnal below integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< Identifiered for z* coordinates at the bottom, !! sigma-near the top integer, parameter :: REGRIDDING_ADAPTIVE = 9 !< Adaptive coordinate mode identifier @@ -31,7 +29,6 @@ module regrid_consts character(len=*), parameter :: REGRIDDING_ARBITRARY_STRING = "ARB" !< Arbitrary coordinates character(len=*), parameter :: REGRIDDING_HYCOM1_STRING = "HYCOM1" !< Hycom string character(len=*), parameter :: REGRIDDING_HYBGEN_STRING = "HYBGEN" !< Hybgen string -character(len=*), parameter :: REGRIDDING_SLIGHT_STRING = "SLIGHT" !< Hybrid S-rho string character(len=*), parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string character(len=*), parameter :: DEFAULT_COORDINATE_MODE = REGRIDDING_LAYER_STRING !< Default coordinate mode @@ -63,7 +60,6 @@ function coordinateMode(string) case (trim(REGRIDDING_SIGMA_STRING)); coordinateMode = REGRIDDING_SIGMA case (trim(REGRIDDING_HYCOM1_STRING)); coordinateMode = REGRIDDING_HYCOM1 case (trim(REGRIDDING_HYBGEN_STRING)); coordinateMode = REGRIDDING_HYBGEN - case (trim(REGRIDDING_SLIGHT_STRING)); coordinateMode = REGRIDDING_SLIGHT case (trim(REGRIDDING_ARBITRARY_STRING)); coordinateMode = REGRIDDING_ARBITRARY case (trim(REGRIDDING_SIGMA_SHELF_ZSTAR_STRING)); coordinateMode = REGRIDDING_SIGMA_SHELF_ZSTAR case (trim(REGRIDDING_ADAPTIVE_STRING)); coordinateMode = REGRIDDING_ADAPTIVE @@ -85,7 +81,6 @@ function coordinateUnitsI(coordMode) case (REGRIDDING_SIGMA); coordinateUnitsI = "Non-dimensional" case (REGRIDDING_HYCOM1); coordinateUnitsI = "m" case (REGRIDDING_HYBGEN); coordinateUnitsI = "m" - case (REGRIDDING_SLIGHT); coordinateUnitsI = "m" case (REGRIDDING_ADAPTIVE); coordinateUnitsI = "m" case default ; call MOM_error(FATAL, "coordinateUnts: "//& "Unrecognized coordinate mode.") @@ -121,7 +116,6 @@ logical function state_dependent_int(mode) case (REGRIDDING_SIGMA); state_dependent_int = .false. case (REGRIDDING_HYCOM1); state_dependent_int = .true. case (REGRIDDING_HYBGEN); state_dependent_int = .true. - case (REGRIDDING_SLIGHT); state_dependent_int = .true. case (REGRIDDING_ADAPTIVE); state_dependent_int = .true. case default ; call MOM_error(FATAL, "state_dependent: "//& "Unrecognized choice of coordinate.") diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 99e6c386c6..9152efa9ec 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -73,6 +73,14 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "ZSTAR_RIGID_SURFACE_THRESHOLD") call obsolete_logical(param_file, "HENYEY_IGW_BACKGROUND_NEW") + call obsolete_real(param_file, "SLIGHT_DZ_SURFACE") + call obsolete_int(param_file, "SLIGHT_NZ_SURFACE_FIXED") + call obsolete_real(param_file, "SLIGHT_SURFACE_AVG_DEPTH") + call obsolete_real(param_file, "SLIGHT_NLAY_TO_INTERIOR") + call obsolete_logical(param_file, "SLIGHT_FIX_HALOCLINES") + call obsolete_real(param_file, "HALOCLINE_FILTER_LENGTH") + call obsolete_real(param_file, "HALOCLINE_STRAT_TOL") + ! Test for inconsistent parameter settings. split = .true. ; test_logic = .false. call read_param(param_file,"SPLIT",split) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index cd5682d2d9..ff0eda6325 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -327,10 +327,6 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe call build_rho_column(get_rho_CS(remap_cs%regrid_cs), GV%ke, & GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) - elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then -! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & -! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) - call MOM_error(FATAL,"diag_remap_update: SLIGHT coordinate not coded for diagnostics yet!") elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then ! call build_hycom1_column(remap_cs%regrid_cs, nz, & ! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) From a6f813e059c2b07dfb27b1bbd2b9e501d1817fba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Mar 2023 14:10:14 -0400 Subject: [PATCH 31/91] (*)Fix MOM_calc_grad_Coriolis GLOBAL_INDEXING bug Fixed a bug in MOM_calculate_grad_Coriolis() that was causing the model to hang due to mismatched halo updates when GLOBAL_INDEXING = True. Also added missing callTree (a.k.a. granny tracker) calls at the start and end of the same routine. All answers are bitwise identical in any cases that worked before. --- src/initialization/MOM_shared_initialization.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 2981bb9e94..46d0448699 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -96,11 +96,13 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) intent(out) :: dF_dy !< y-component of grad f [T-1 L-1 ~> s-1 m-1] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables + character(len=40) :: mdl = "MOM_calculate_grad_Coriolis" ! This subroutine's name. integer :: i,j real :: f1, f2 ! Average of adjacent Coriolis parameters [T-1 ~> s-1] + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") if ((LBOUND(G%CoriolisBu,1) > G%isc-1) .or. & - (LBOUND(G%CoriolisBu,2) > G%isc-1)) then + (LBOUND(G%CoriolisBu,2) > G%jsc-1)) then ! The gradient of the Coriolis parameter can not be calculated with this grid. dF_dx(:,:) = 0.0 ; dF_dy(:,:) = 0.0 return @@ -115,6 +117,7 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) dF_dy(i,j) = G%IdyT(i,j) * ( f1 - f2 ) enddo ; enddo call pass_vector(dF_dx, dF_dy, G%Domain, stagger=AGRID) + call callTree_leave(trim(mdl)//'()') end subroutine MOM_calculate_grad_Coriolis From 30371003eb5b139b726c67f14e1f420c19978973 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 2 Jun 2022 15:14:59 -0400 Subject: [PATCH 32/91] Document and unit test for mu(z) in MLE parameterization - Renamed function from psi(z) to mu(sigma) - Added comments and units in function mu(sigma) - Added [numerical] unit tests for mu(z), including special limits, special values, and one test value (checked against a python script). --- src/core/MOM_unit_tests.F90 | 3 + .../lateral/MOM_mixed_layer_restrat.F90 | 135 ++++++++++++++---- 2 files changed, 110 insertions(+), 28 deletions(-) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 10782e8890..8811990c4f 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -11,6 +11,7 @@ module MOM_unit_tests use MOM_random, only : random_unit_tests use MOM_lateral_boundary_diffusion, only : near_boundary_unit_tests use MOM_CFC_cap, only : CFC_cap_unit_tests +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests implicit none ; private public unit_tests @@ -40,6 +41,8 @@ subroutine unit_tests(verbosity) "MOM_unit_tests: near_boundary_unit_tests FAILED") if (CFC_cap_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: CFC_cap_unit_tests FAILED") + if (mixedlayer_restrat_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: mixedlayer_restrat_unit_tests FAILED") endif end subroutine unit_tests diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index ffdf236152..cac1886bd1 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -27,6 +27,7 @@ module MOM_mixed_layer_restrat public mixedlayer_restrat public mixedlayer_restrat_init public mixedlayer_restrat_register_restarts +public mixedlayer_restrat_unit_tests ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -408,9 +409,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! The sum of a(k) through the mixed layers must be 0. do k=1,nz hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) - a(k) = PSI(zpa) ! Psi(z/MLD) for upper interface - zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface - a(k) = a(k) - PSI(zpa) ! Transport profile + a(k) = mu(zpa, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface + a(k) = a(k) - mu(zpa, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (uDml) if it would violate CFL if (a(k)*uDml(I) > 0.0) then if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) @@ -421,9 +422,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var do k=1,nz ! Transport for slow-filtered MLD hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) - b(k) = PSI(zpb) ! Psi(z/MLD) for upper interface - zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface - b(k) = b(k) - PSI(zpb) ! Transport profile + b(k) = mu(zpb, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface + b(k) = b(k) - mu(zpb, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (uDml_slow) if it would violate CFL when added to uDml if (b(k)*uDml_slow(I) > 0.0) then if (b(k)*uDml_slow(I) > h_avail(i,j,k) - a(k)*uDml(I)) & @@ -476,9 +477,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! The sum of a(k) through the mixed layers must be 0. do k=1,nz hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) - a(k) = PSI( zpa ) ! Psi(z/MLD) for upper interface - zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface - a(k) = a(k) - PSI( zpa ) ! Transport profile + a(k) = mu(zpa, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface + a(k) = a(k) - mu(zpa, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (vDml) if it would violate CFL if (a(k)*vDml(i) > 0.0) then if (a(k)*vDml(i) > h_avail(i,j,k)) vDml(i) = h_avail(i,j,k) / a(k) @@ -489,9 +490,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var do k=1,nz ! Transport for slow-filtered MLD hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) - b(k) = PSI(zpb) ! Psi(z/MLD) for upper interface - zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface - b(k) = b(k) - PSI(zpb) ! Transport profile + b(k) = mu(zpb, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface + b(k) = b(k) - mu(zpb, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (vDml_slow) if it would violate CFL when added to vDml if (b(k)*vDml_slow(i) > 0.0) then if (b(k)*vDml_slow(i) > h_avail(i,j,k) - a(k)*vDml(i)) & @@ -540,14 +541,14 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (CS%id_uml > 0) then do J=js,je ; do i=is-1,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) - uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (PSI(0.)-PSI(-.01)) + uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo call post_data(CS%id_uml, uDml_diag, CS%diag) endif if (CS%id_vml > 0) then do J=js-1,je ; do i=is,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) - vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (PSI(0.)-PSI(-.01)) + vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo call post_data(CS%id_vml, vDml_diag, CS%diag) endif @@ -557,25 +558,44 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! This needs to happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) -contains - !> Stream function [nondim] as a function of non-dimensional position within mixed-layer - real function psi(z) - real, intent(in) :: z !< Fractional mixed layer depth [nondim] - real :: psi1 ! The streamfunction structure without the tail [nondim] - real :: bottop, xp, dd ! Local work variables used to generate the streamfunction tail [nondim] +end subroutine mixedlayer_restrat_general - !psi1 = max(0., (1. - (2.*z + 1.)**2)) - psi1 = max(0., (1. - (2.*z + 1.)**2) * (1. + (5./21.)*(2.*z + 1.)**2)) +!> Stream function shape as a function of non-dimensional position within mixed-layer [nondim] +real function mu(sigma, dh) + real, intent(in) :: sigma !< Fractional position within mixed layer [nondim] + !! z=0 is surface, z=-1 is the bottom of the mixed layer + real, intent(in) :: dh !< Non-dimensional distance over which to extend stream + !! function to smooth transport at base [nondim] + ! Local variables + real :: xp !< A linear function from mid-point of the mixed-layer + !! to the extended mixed-layer bottom [nondim] + real :: bottop !< A mask, 0 in upper half of mixed layer, 1 otherwise [nondim] + real :: dd !< A cubic(-ish) profile in lower half of extended mixed + !! layer to smooth out the parameterized transport [nondim] - xp = max(0., min(1., (-z - 0.5)*2. / (1. + 2.*CS%MLE_tail_dh))) - dd = (1. - 3.*(xp**2) + 2.*(xp**3))**(1. + 2.*CS%MLE_tail_dh) - bottop = 0.5*(1. - sign(1., z + 0.5)) ! =0 for z>-0.5, =1 for z<-0.5 + ! Lower order shape (not used), see eq 10 from FK08b. + ! Apparently used in CM2G, see eq 14 of FK11. + !mu = max(0., (1. - (2.*sigma + 1.)**2)) - psi = max(psi1, dd*bottop) ! Combines original psi1 with tail - end function psi + ! Second order, in Rossby number, shape. See eq 21 from FK08a, eq 9 from FK08b, eq 5 FK11 + mu = max(0., (1. - (2.*sigma + 1.)**2) * (1. + (5./21.)*(2.*sigma + 1.)**2)) -end subroutine mixedlayer_restrat_general + ! -0.5 < sigma : xp(sigma)=0 (upper half of mixed layer) + ! -1.0+dh < sigma < -0.5 : xp(sigma)=linear (lower half +dh of mixed layer) + ! sigma < -1.0+dh : xp(sigma)=1 (below mixed layer + dh) + xp = max(0., min(1., (-sigma - 0.5)*2. / (1. + 2.*dh))) + ! -0.5 < sigma : dd(sigma)=1 (upper half of mixed layer) + ! -1.0+dh < sigma < -0.5 : dd(sigma)=cubic (lower half +dh of mixed layer) + ! sigma < -1.0+dh : dd(sigma)=0 (below mixed layer + dh) + dd = (1. - 3.*(xp**2) + 2.*(xp**3))**(1. + 2.*dh) + + ! -0.5 < sigma : bottop(sigma)=0 (upper half of mixed layer) + ! sigma < -0.5 : bottop(sigma)=1 (below upper half) + bottop = 0.5*(1. - sign(1., sigma + 0.5)) ! =0 for sigma>-0.5, =1 for sigma<-0.5 + + mu = max(mu, dd*bottop) ! Combines original psi1 with tail +end function mu !> Calculates a restratifying flow assuming a 2-layer bulk mixed layer. subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) @@ -1057,6 +1077,65 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest end subroutine mixedlayer_restrat_register_restarts +logical function mixedlayer_restrat_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(mixedlayer_restrat_CS) :: CS ! Control structure + logical :: this_test + + print *,'===== mixedlayer_restrat: mixedlayer_restrat_unit_tests ==================' + + ! Tests of the shape function mu(z) + this_test = & + test_answer(verbose, mu(3.,0.), 0., 'mu(3)=0') + this_test = this_test .or. & + test_answer(verbose, mu(0.,0.), 0., 'mu(0)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-0.25,0.), 0.7946428571428572, 'mu(-0.25)=0.7946...', tol=epsilon(1.)) + this_test = this_test .or. & + test_answer(verbose, mu(-0.5,0.), 1., 'mu(-0.5)=1') + this_test = this_test .or. & + test_answer(verbose, mu(-0.75,0.), 0.7946428571428572, 'mu(-0.75)=0.7946...', tol=epsilon(1.)) + this_test = this_test .or. & + test_answer(verbose, mu(-1.,0.), 0., 'mu(-1)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-3.,0.), 0., 'mu(-3)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-0.5,0.5), 1., 'mu(-0.5,0.5)=1') + this_test = this_test .or. & + test_answer(verbose, mu(-1.,0.5), 0.25, 'mu(-1,0.5)=0.25') + this_test = this_test .or. & + test_answer(verbose, mu(-1.5,0.5), 0., 'mu(-1.5,0.5)=0') + if (.not. this_test) print '(a)',' Passed tests of mu(z)' + mixedlayer_restrat_unit_tests = this_test + +end function mixedlayer_restrat_unit_tests + +!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. +logical function test_answer(verbose, u, u_true, label, tol) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: u !< Values to test + real, intent(in) :: u_true !< Values to test against (correct answer) + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true + ! Local variables + real :: tolerance ! The tolerance for differences between u and u_true + integer :: k + + tolerance = 0.0 ; if (present(tol)) tolerance = tol + test_answer = .false. + + if (abs(u - u_true) > tolerance) test_answer = .true. + if (test_answer .or. verbose) then + if (test_answer) then + print '(1p2e24.16,a,1pe24.16,a,x,a)',u,u_true,' err=',u-u_true,' < wrong',label + else + print '(2(a,1pe24.16),x,a)','computed =',u,' correct =',u_true,label + endif + endif + +end function test_answer + !> \namespace mom_mixed_layer_restrat !! !! \section section_mle Mixed-layer eddy parameterization module From 5d5df200304da0cfe7b85cc7f47a384544dcaf31 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 8 Jun 2022 16:34:47 -0400 Subject: [PATCH 33/91] Adds the Bodner et al. 2023 version of MLE Changes: - Allow MLE parameterization to see surface buoyancy flux return from PBL scheme (affects MOM.F90, MOM_variables.F90:vertvisc_type, MOM_diabatic_driver.F90, MOM_set_viscosity.F90) - Adds the Bodner et al., 2023, parameterization of restratification by mixed-layer eddies to MOM_mixed_layer_restrat.F90 - This is a new subroutine rather than embedded inside the previous "OM4" version. It uses different inputs, different parameters, filters the BLD differently, - Renamed mixedlayer_restrat_general to mxiedlayer_restrat_OM4 to better distinguish the two versions. - Added function rmean2ts to extend the resetting running-mean time filter used in OM4 to use different time scales when growing or decaying. While mathematically the same in the limit of a zero "growing" time-scale, the implementation differs in the use of a reciprocal instead of division so was not added to the OM4 version. - Updated module documentation Co-authored-by: Abigail Bodner --- src/core/MOM.F90 | 2 +- src/core/MOM_variables.F90 | 4 +- .../lateral/MOM_mixed_layer_restrat.F90 | 698 ++++++++++++++++-- .../vertical/MOM_diabatic_driver.F90 | 20 + .../vertical/MOM_set_viscosity.F90 | 11 +- 5 files changed, 661 insertions(+), 74 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 84eb5fc90a..54695e6636 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1263,7 +1263,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif call cpu_clock_begin(id_clock_ml_restrat) call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & - CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) + CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) call cpu_clock_end(id_clock_ml_restrat) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (CS%debug) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 6aa94f584f..5efb02fe44 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -257,8 +257,8 @@ module MOM_variables Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [Z T-1 ~> m s-1]. ! The following elements are pointers so they can be used as targets for pointers in the restart registry. - real, pointer, dimension(:,:) :: & - MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. + real, pointer, dimension(:,:) :: MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. + real, pointer, dimension(:,:) :: sfc_buoy_flx !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. real, pointer, dimension(:,:,:) :: Kd_shear => NULL() !< The shear-driven turbulent diapycnal diffusivity at the interfaces between layers !! in tracer columns [Z2 T-1 ~> m2 s-1]. diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index cac1886bd1..848fd031e2 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -10,6 +10,7 @@ module MOM_mixed_layer_restrat use MOM_domains, only : pass_var, To_West, To_South, Omit_Corners use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type @@ -58,7 +59,30 @@ module MOM_mixed_layer_restrat !! the mixed-layer [nondim]. real :: MLE_MLD_stretch !< A scaling coefficient for stretching/shrinking the MLD used in !! the MLE scheme [nondim]. This simply multiplies MLD wherever used. + + ! The following parameters are used in the Bodner et al., 2023, parameterization + logical :: use_Bodner = .false. !< If true, use the Bodner et al., 2023, parameterization. + real :: Cr !< Efficiency coefficient from Bodner et al., 2023 + real :: mstar !< The m* value used to estimate the turbulent vertical momentum flux [nondim] + real :: nstar !< The n* value used to estimate the turbulent vertical momentum flux [nondim] + real :: min_wstar2 !< The minimum lower bound to apply to the vertical momentum flux, w'u', + !! in the Bodner et al., restratification parameterization. This avoids + !! a division-by-zero in the limit when u* and the buoyancy flux are zero. [Z2 T-2] + real :: BLD_growing_Tfilt !< The time-scale for a running-mean filter applied to the boundary layer + !! depth (BLD) when the BLD is deeper than the running mean. A value of 0 + !! instantaneously sets the running mean to the current value of BLD. [T ~> s] + real :: BLD_decaying_Tfilt !< The time-scale for a running-mean filter applied to the boundary layer + !! depth (BLD) when the BLD is shallower than the running mean. A value of 0 + !! instantaneously sets the running mean to the current value of BLD. + real :: MLD_decaying_Tfilt !< The time-scale for a running-mean filter applied to the time-filtered + !! BLD, when the latter is deeper than the running mean. A value of 0 + !! instantaneously sets the running mean to the current value filtered BLD. [T ~> s] + real :: MLD_growing_Tfilt !< The time-scale for a running-mean filter applied to the time-filtered + !! BLD, when the latter is deeper than the running mean. A value of 0 + !! instantaneously sets the running mean to the current value filtered BLD. [T ~> s] + logical :: debug = .false. !< If true, calculate checksums of fields for debugging. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. logical :: use_stanley_ml !< If true, use the Stanley parameterization of SGS T variance @@ -68,7 +92,8 @@ module MOM_mixed_layer_restrat real, dimension(:,:), allocatable :: & MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] - MLD_filtered_slow !< Slower time-filtered MLD [H ~> m or kg m-2] + MLD_filtered_slow, & !< Slower time-filtered MLD [H ~> m or kg m-2] + wpup_filtered !< Time-filtered vertical momentum flux [Z2 T-2 ~> m2 s-2] !>@{ !! Diagnostic identifier @@ -77,11 +102,15 @@ module MOM_mixed_layer_restrat integer :: id_uhml = -1 integer :: id_vhml = -1 integer :: id_MLD = -1 + integer :: id_BLD = -1 integer :: id_Rml = -1 integer :: id_uDml = -1 integer :: id_vDml = -1 integer :: id_uml = -1 integer :: id_vml = -1 + integer :: id_wpup = -1 + integer :: id_ustar = -1 + integer :: id_bflux = -1 !>@} end type mixedlayer_restrat_CS @@ -93,7 +122,7 @@ module MOM_mixed_layer_restrat !> Driver for the mixed-layer restratification parameterization. !! The code branches between two different implementations depending !! on whether the bulk-mixed layer or a general coordinate are in use. -subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, bflux, VarMix, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -107,22 +136,29 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the !! planetary boundary layer scheme [Z ~> m] + real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the + !! PBL scheme [Z2 T-3 ~> m2 s-3] type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + if (.not. CS%initialized) call MOM_error(FATAL, "mixedlayer_restrat: "// & "Module must be initialized before it is used.") if (GV%nkml>0) then + ! Original form, written for the isopycnal model with a bulk mixed layer call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) + elseif (CS%use_Bodner) then + ! Implementation of Bodner et al., 2023 + call mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, MLD, bflux) else - call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) - endif + ! Implementation of Fox-Kemper et al., 2008, to work in general coordinates + call mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) +endif end subroutine mixedlayer_restrat -!> Calculates a restratifying flow in the mixed layer. -subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, US, CS) +!> Calculates a restratifying flow in the mixed layer, following the formulation used in OM4 +subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, US, CS) ! Arguments type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -206,10 +242,10 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var covTS(:) = 0.0 !!Functionality not implemented yet; in future, should be passed in tv varS(:) = 0.0 - if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "An equation of state must be used with this module.") if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & - call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "The resolution argument, Rd/dx, was not associated.") if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. @@ -218,7 +254,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var EOSdom(:) = EOS_domain(G%HI, halo=1) do j = js-1, je+1 dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer - if (CS%use_stanley_ml) then + if (CS%use_Stanley_ML) then call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, tv%varT(:,j,1), covTS, varS, & rhoSurf, tv%eqn_of_state, EOSdom) else @@ -231,7 +267,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K ! Mixed-layer depth, using sigma-0 (surface reference pressure) deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K - if (CS%use_stanley_ml) then + if (CS%use_Stanley_ML) then call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, tv%varT(:,j,k), covTS, varS, & deltaRhoAtK, tv%eqn_of_state, EOSdom) else @@ -260,7 +296,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%Z_to_H) * MLD_in(i,j) enddo ; enddo else - call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "No MLD to use for MLE parameterization.") endif @@ -333,7 +369,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then - if (CS%use_stanley_ml) then + if (CS%use_Stanley_ML) then call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & rho_ml(:), tv%eqn_of_state, EOSdom) else @@ -533,7 +569,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (CS%id_vrestrat_time > 0) call post_data(CS%id_vrestrat_time, vtimescale_diag, CS%diag) if (CS%id_uhml > 0) call post_data(CS%id_uhml, uhml, CS%diag) if (CS%id_vhml > 0) call post_data(CS%id_vhml, vhml, CS%diag) - if (CS%id_MLD > 0) call post_data(CS%id_MLD, MLD_fast, CS%diag) + if (CS%id_BLD > 0) call post_data(CS%id_BLD, MLD_fast, CS%diag) + if (CS%id_MLD > 0) call post_data(CS%id_MLD, MLD_slow, CS%diag) if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rml_av_fast, CS%diag) if (CS%id_uDml > 0) call post_data(CS%id_uDml, uDml_diag, CS%diag) if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) @@ -558,7 +595,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! This needs to happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) -end subroutine mixedlayer_restrat_general +end subroutine mixedlayer_restrat_OM4 !> Stream function shape as a function of non-dimensional position within mixed-layer [nondim] real function mu(sigma, dh) @@ -597,6 +634,355 @@ real function mu(sigma, dh) mu = max(mu, dd*bottop) ! Combines original psi1 with tail end function mu +!> Calculates a restratifying flow in the mixed layer, following the formulation +!! used in Bodner et al., 2023 (B22) +subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, BLD, bflux) + ! Arguments + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + real, dimension(:,:), pointer :: BLD !< Active boundary layer depth provided by the + !! PBL scheme [Z ~> m] (not H) + real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the + !! PBL scheme [Z2 T-3 ~> m2 s-3] + ! Local variables + real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vol_dt_avail(SZI_(G),SZJ_(G),SZK_(GV)) ! The volume available for exchange out of each face of + ! each layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + little_h, & ! "Little h" representing active mixing layer depth [Z ~> m] + big_H, & ! "Big H" representing the mixed layer depth [Z ~> m] + htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + buoy_av, & ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] + wpup ! Turbulent vertical momentum [ ????? ~> m2 s-2] + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [degC ppt] + real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [ppt2] + real :: dmu(SZK_(GV)) ! Change in mu(z) across layer k [nondim] + real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] + real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] + real :: w_star3 ! Cube of turbulent convective velocity [m3 s-3] + real :: u_star3 ! Cube of surface fruction velocity [m3 s-3] + real :: r_wpup ! reciprocal of vertical momentum flux [Z-2 T2 ~> m-2 s2] + real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] + real :: grid_dsd ! combination of grid scales [L2 ~> m2] + real :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [Z ~> m] + real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [Z ~> m] + real :: grd_b ! The vertically average gradient of buoyancy [L Z-1 T-2 ~> s-2] + real :: psi_mag ! Magnitude of stream function [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] + real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] + real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] + real :: sigint ! Fractional position within the mixed layer of the interface above a layer [nondim] + real :: muzb ! mu(z) at bottom of the layer [nondim] + real :: muza ! mu(z) at top of the layer [nondim] + real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] + real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] + real, parameter :: two_thirds = 2./3. + logical :: line_is_empty, keep_going + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + I4dt = 0.25 / dt + g_Rho0 = GV%g_Earth / GV%Rho0 + h_neglect = GV%H_subroundoff + + covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. + varS(:) = 0.0 ! Ditto. + + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "An equation of state must be used with this module.") + if (.not.CS%MLE_use_PBL_MLD) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "To use the Bodner et al., 2023, MLE parameterization, MLE_USE_PBL_MLD must be True.") + if (CS%MLE_density_diff > 0.) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "MLE_density_diff is +ve and should not be in mixedlayer_restrat_Bodner.") + if (.not.associated(bflux)) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "Surface buoyancy flux was not associated.") + + call pass_var(bflux, G%domain, halo=1) + + if (CS%debug) then + call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(BLD, 'mle_Bodner: BLD in', G%HI, haloshift=1, scale=US%Z_to_m) + if (associated(bflux)) & + call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, scale=US%Z_to_m**2*US%s_to_T**3) + call hchksum(forces%ustar,'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) + call hchksum(CS%MLD_filtered, 'mle_Bodner: MLD_filtered 1', & + G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & + G%HI, haloshift=1, scale=US%Z_to_m) + endif + + ! Apply time filter to BLD (to remove diurnal cycle) to obtain "little h". + ! "little h" is representative of the active mixing layer depth, used in B22 formula (eq 27). + do j = js-1, je+1 ; do i = is-1, ie+1 + little_h(i,j) = rmean2ts(BLD(i,j), CS%MLD_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%MLD_filtered(i,j) = little_h(i,j) + enddo ; enddo + + ! Calculate "big H", representative of the mixed layer depth, used in B22 formula (eq 27). + do j = js-1, je+1 ; do i = is-1, ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) + CS%MLD_filtered_slow(i,j) = big_H(i,j) + enddo ; enddo + + ! Estimate w'u' at h-points + do j = js-1, je+1 ; do i = is-1, ie+1 + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) & ! (this line in Z3 T-3 ~> m3 s-3) + * ( ( US%Z_to_m * US%s_to_T )**3 ) ! m3 s-3 + u_star3 = ( US%Z_to_m * US%s_to_T * forces%ustar(i,j) )**3 ! m3 s-3 + wpup(i,j) = max( CS%min_wstar2, & ! The max() avoids division by zero later + ( CS%mstar * u_star3 + CS%nstar * w_star3 )**two_thirds ) & ! (this line m2 s-2) + * ( ( US%m_to_Z * US%T_to_s )**2 ) ! Z2 T-2 ~> m2 s-2 + ! We filter w'u' with the same time scales used for "little h" + wpup(i,j) = rmean2ts(wpup(i,j), CS%wpup_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%wpup_filtered(i,j) = wpup(i,j) + enddo ; enddo + + if (CS%debug) then + call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(CS%MLD_filtered,'mle_Bodner: MLD_filtered 2', & + G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 2', & + G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, scale=(US%Z_to_m*US%s_to_T)**2) + endif + + ! Calculate the average density in the "mixed layer". + ! Notice we use p=0 (sigma_0) since horizontal differences of vertical averages of + ! in-situ density would contain the MLD gradient (through the pressure dependence). + p0(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI, halo=1) + !$OMP parallel & + !$OMP default(shared) & + !$OMP private(i, j, k, keep_going, line_is_empty, dh, & + !$OMP grid_dsd, absf, h_sml, h_big, grd_b, r_wpup, psi_mag, IhTot, & + !$OMP sigint, muzb, muza, hAtVel) + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; buoy_av(i,j) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + vol_dt_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + if (keep_going) then + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + rho_ml(:), tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) + endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot(i,j) < big_H(i,j)*GV%Z_to_H) then + dh = min( h(i,j,k), big_H(i,j)*GV%Z_to_H - htot(i,j) ) + buoy_av(i,j) = buoy_av(i,j) + dh*rho_ml(i) ! Here, buoy_av has units of R H ~> kg m-2 + htot(i,j) = htot(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + do i=is-1,ie+1 + ! Hereafter, buoy_av has units (L2 Z-1 T-2 R-1) * (R H) * H-1 = L2 Z-1 T-2 ~> m s-2 + buoy_av(i,j) = -( g_Rho0 * buoy_av(i,j) ) / (htot(i,j) + h_neglect) + enddo + enddo + + if (CS%debug) then + call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(vol_dt_avail,'mle_Bodner: vol_dt_avail', G%HI, haloshift=1, & + scale=US%L_to_m**2*GV%H_to_m*US%s_to_T) + call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, & + scale=US%m_to_Z*US%L_T_to_m_s**2) + endif + + ! U - Component + !$OMP do + do j=js,je ; do I=is-1,ie + grid_dsd = sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) & ! L2 ~> m2 + * G%dyCu(I,j) + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! T-1 ~> s-1 + h_sml = 0.5*( little_h(i,j) + little_h(i+1,j) ) ! Z ~> m + h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! Z ~> m + grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L Z-1 T-2 ~> s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! Z-2 T2 ~> m-2 s2 + psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( ( h_big**2 ) * grd_b ) ) * r_wpup & + * G%mask2dCu(I,j) * GV%Z_to_H + + IhTot = 2.0 / ((htot(i,j) + htot(i+1,j)) + h_neglect) ! [H-1] + sigint = 0.0 + muzb = 0.0 ! This will be the first value of muza = mu(z=0) + do k=1,nz + muza = muzb ! mu(z/MLD) for upper interface [nondim] + hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) ! Thickness at velocity point [H] + sigint = sigint - (hAtVel * IhTot) ! z/H for lower interface [nondim] + muzb = mu(sigint, CS%MLE_tail_dh) ! mu(z/MLD) for lower interface [nondim] + dmu(k) = muza - muzb ! Change in mu(z) across layer [nondim] + ! dmu(k)*psi_mag is the transport in this layer [L2 H T-1 ~> m3 s-1] + ! Limit magnitude (psi_mag) if it would violate CFL + if (dmu(k)*psi_mag > 0.0) then + if (dmu(k)*psi_mag > vol_dt_avail(i,j,k)) psi_mag = vol_dt_avail(i,j,k) / dmu(k) + elseif (dmu(k)*psi_mag < 0.0) then + if (-dmu(k)*psi_mag > vol_dt_avail(i+1,j,k)) psi_mag = -vol_dt_avail(i+1,j,k) / dmu(k) + endif + enddo ! These loops cannot be fused because psi_mag applies to the whole column + do k=1,nz + uhml(I,j,k) = dmu(k) * psi_mag ! [ L2 H T-1 ] + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k) * dt ! [ L2 H ] + enddo + + uDml_diag(I,j) = psi_mag + enddo ; enddo + + ! V- component + !$OMP do + do J=js-1,je ; do i=is,ie + grid_dsd = sqrt( 0.5 * ( G%dxCv(i,J)**2 + G%dyCv(i,J)**2 ) ) & ! L2 ~> m2 + * G%dxCv(i,J) + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! T-1 ~> s-1 + h_sml = 0.5*( little_h(i,j) + little_h(i,j+1) ) ! Z ~> m + h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! Z ~> m + grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L Z-1 T-2 ~> s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! Z-2 T2 ~> m-2 s2 + psi_mag = ( ( ( CS%Cr * grid_dsd ) * ( absf * h_sml ) ) & ! L2 H T-1 ~> m3 s-1 or kg s-1 + * ( ( h_big**2 ) * grd_b ) ) * r_wpup & + * G%mask2dCv(i,J) * GV%Z_to_H + + IhTot = 2.0 / ((htot(i,j) + htot(i,j+1)) + h_neglect) ! [H-1] + sigint = 0.0 + muzb = 0.0 ! This will be the first value of muza = mu(z=0) + do k=1,nz + muza = muzb ! mu(z/MLD) for upper interface [nondim] + hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) ! Thickness at velocity point [H] + sigint = sigint - (hAtVel * IhTot) ! z/H for lower interface [nondim] + muzb = mu(sigint, CS%MLE_tail_dh) ! mu(z/MLD) for lower interface [nondim] + dmu(k) = muza - muzb ! Change in mu(z) across layer [nondim] + ! dmu(k)*psi_mag is the transport in this layer [L2 H T-1 ~> m3 s-1] + ! Limit magnitude (psi_mag) if it would violate CFL + if (dmu(k)*psi_mag > 0.0) then + if (dmu(k)*psi_mag > vol_dt_avail(i,j,k)) psi_mag = vol_dt_avail(i,j,k) / dmu(k) + elseif (dmu(k)*psi_mag < 0.0) then + if (-dmu(k)*psi_mag > vol_dt_avail(i,j+1,k)) psi_mag = -vol_dt_avail(i,j+1,k) / dmu(k) + endif + enddo ! These loops cannot be fused because psi_mag applies to the whole column + do k=1,nz + vhml(i,J,k) = dmu(k) * psi_mag ! [ L2 H T-1 ] + vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k) * dt ! [ L2 H ] + enddo + + vDml_diag(i,J) = psi_mag + enddo ; enddo + + !$OMP do + do j=js,je ; do k=1,nz ; do i=is,ie + h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & + ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + enddo ; enddo ; enddo + !$OMP end parallel + + if (CS%id_uhml > 0 .or. CS%id_vhml > 0) & + ! Remapped uhml and vhml require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_ustar > 0) call post_data(CS%id_ustar, forces%ustar, CS%diag) + if (CS%id_bflux > 0) call post_data(CS%id_bflux, bflux, CS%diag) + if (CS%id_wpup > 0) call post_data(CS%id_wpup, wpup, CS%diag) + if (CS%id_Rml > 0) call post_data(CS%id_Rml, buoy_av, CS%diag) + if (CS%id_BLD > 0) call post_data(CS%id_BLD, little_h, CS%diag) + if (CS%id_MLD > 0) call post_data(CS%id_MLD, big_H, CS%diag) + if (CS%id_uhml > 0) call post_data(CS%id_uhml, uhml, CS%diag) + if (CS%id_vhml > 0) call post_data(CS%id_vhml, vhml, CS%diag) + if (CS%id_uDml > 0) call post_data(CS%id_uDml, uDml_diag, CS%diag) + if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) + + if (CS%id_uml > 0) then + do J=js,je ; do i=is-1,ie + h_vel = 0.5*((htot(i,j) + htot(i+1,j)) + h_neglect) + uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_uml, uDml_diag, CS%diag) + endif + if (CS%id_vml > 0) then + do J=js-1,je ; do i=is,ie + h_vel = 0.5*((htot(i,j) + htot(i,j+1)) + h_neglect) + vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_vml, vDml_diag, CS%diag) + endif + endif + +end subroutine mixedlayer_restrat_Bodner + +!> Two time-scale running mean [units of "signal" and "filtered"] +!! +!! If signal > filtered, returns running-mean with time scale "tau_growing". +!! If signal <= filtered, returns running-mean with time scale "tau_decaying". +!! +!! The running mean of \f$ s \f$ with time scale "of \f$ \tau \f$ is: +!! \f[ +!! \bar{s} <- ( \Delta t * s + \tau * \bar{s} ) / ( \Delta t + \tau ) +!! \f] +!! +!! Note that if \f$ tau=0 \f$, then the running mean equals the signal. Thus, +!! rmean2ts with tau_growing=0 recovers the "resetting running mean" used in OM4. +real elemental function rmean2ts(signal, filtered, tau_growing, tau_decaying, dt) + ! Arguments + real, intent(in) :: signal ! Unfiltered signal [arbitrary units] + real, intent(in) :: filtered ! Current value of running mean [arbitrary units] + real, intent(in) :: tau_growing ! Time scale for growing signal [T ~> s] + real, intent(in) :: tau_decaying ! Time scale for decaying signal [T ~> s] + real, intent(in) :: dt ! Time step [T ~> s] + ! Local variables + real :: afac, bfac ! Non-dimensional weights + real :: rt ! Reciprocal time scale [T-1 ~> s-1] + + if (signal>=filtered) then + rt = 1.0 / ( dt + tau_growing ) + aFac = tau_growing * rt + bFac = 1. - aFac + else + rt = 1.0 / ( dt + tau_decaying ) + aFac = tau_decaying * rt + bFac = 1. - aFac + endif + + rmean2ts = aFac * filtered + bFac * signal + +end function rmean2ts + !> Calculates a restratifying flow assuming a 2-layer bulk mixed layer. subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -652,7 +1038,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nkml = GV%nkml - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + if (.not. CS%initialized) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "Module must be initialized before it is used.") if ((nkml<2) .or. (CS%ml_restrat_coef<=0.0)) return @@ -666,12 +1052,11 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z - if (.not.use_EOS) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + if (.not.use_EOS) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "An equation of state must be used with this module.") - if (CS%use_stanley_ml) call MOM_error(FATAL, & - "MOM_mixedlayer_restrat: The Stanley parameterization is not"//& - "available with the BML.") + if (CS%use_Stanley_ML) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & + "The Stanley parameterization is not available with the BML.") ! Fix this later for nkml >= 3. @@ -876,6 +1261,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, real :: ustar_min_dflt ! The default value for RESTRAT_USTAR_MIN [Z T-1 ~> m s-1] real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] + real :: BLD_units ! Set to either H_to_m or Z_to_m depending on scheme [m H-1 or m Z-1 ~> 1] ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j @@ -899,9 +1285,78 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%MLE_tail_dh = -9.e9 CS%MLE_use_PBL_MLD = .false. CS%MLE_MLD_stretch = -9.e9 + CS%use_Stanley_ML = .false. + CS%use_Bodner = .false. call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF", CS%ml_restrat_coef, & + call openParameterBlock(param_file,'MLE') ! Prepend MLE% to all parameters + if (GV%nkml==0) then + call get_param(param_file, mdl, "USE_BODNER23", CS%use_Bodner, & + "If true, use the Bodner et al., 2023, formulation of the re-stratifying "//& + "mixed-layer restratification parameterization. This only works in ALE mode.", & + default=.false.) + endif + if (CS%use_Bodner) then + call get_param(param_file, mdl, "CR", CS%CR, & + "The efficiency coefficient in eq 27 of Bodner et al., 2023.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "BODNER_NSTAR", CS%Nstar, & + "The n* value used to estimate the turbulent vertical momentum flux "//& + "in Bodner et al., 2023, eq. 18. This is independent of the value used in "//& + "the PBL scheme but should be set to be the same for consistency.", & + units="nondim", default=0.066) + call get_param(param_file, mdl, "BODNER_MSTAR", CS%Mstar, & + "The m* value used to estimate the turbulent vertical momentum flux "//& + "in Bodner et al., 2023, eq. 18. This is independent of the value used in "//& + "the PBL scheme but should be set to be the same for consistency.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "BLD_GROWING_TFILTER", CS%BLD_growing_Tfilt, & + "The time-scale for a running-mean filter applied to the boundary layer "//& + "depth (BLD) when the BLD is deeper than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value of BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "BLD_DECAYING_TFILTER", CS%BLD_decaying_Tfilt, & + "The time-scale for a running-mean filter applied to the boundary layer "//& + "depth (BLD) when the BLD is shallower than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value of BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MLD_GROWING_TFILTER", CS%MLD_growing_Tfilt, & + "The time-scale for a running-mean filter applied to the time-filtered "//& + "BLD, when the latter is deeper than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value filtered BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MLD_DECAYING_TFILTER", CS%MLD_decaying_Tfilt, & + "The time-scale for a running-mean filter applied to the time-filtered "//& + "BLD, when the latter is shallower than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value filtered BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MIN_WSTAR2", CS%min_wstar2, & + "The minimum lower bound to apply to the vertical momentum flux, w'u', "//& + "in the Bodner et al., restratification parameterization. This avoids "//& + "a division-by-zero in the limit when u* and the buoyancy flux are zero.", & + units="m2 s-2", default=0.) + call get_param(param_file, mdl, "TAIL_DH", CS%MLE_tail_dh, & + "Fraction by which to extend the mixed-layer restratification "//& + "depth used for a smoother stream function at the base of "//& + "the mixed-layer.", units="nondim", default=0.0) + call get_param(param_file, mdl, "USE_STANLEY_TVAR", CS%use_Stanley_ML, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in ML restrat code.", default=.false.) + call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & + "If true, the MLE parameterization will use the mixed-layer "//& + "depth provided by the active PBL parameterization. If false, "//& + "MLE will estimate a MLD based on a density difference with the "//& + "surface using the parameter MLE_DENSITY_DIFF.", default=.false.) + if (.not.CS%MLE_use_PBL_MLD) call MOM_error(FATAL, "mixedlayer_restrat_init: "// & + "To use MLE%USE_BODNER23=True then MLE_USE_PBL_MLD must be True.") + else + call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended + endif + + if (.not.CS%use_Bodner) then + ! This coefficient is used in both layered and ALE versions of Fox-Kemper but not Bodner + call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF", CS%ml_restrat_coef, & "A nondimensional coefficient that is proportional to "//& "the ratio of the deformation radius to the dominant "//& "lengthscale of the submesoscale mixed layer "//& @@ -910,79 +1365,83 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "geostrophic kinetic energy or 1 plus the square of the "//& "grid spacing over the deformation radius, as detailed "//& "by Fox-Kemper et al. (2010)", units="nondim", default=0.0) - call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_stanley_ml, & - "If true, turn on Stanley SGS T variance parameterization "// & - "in ML restrat code.", default=.false.) - if (CS%use_stanley_ml) then - call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & - "Coefficient correlating the temperature gradient and SGS T variance.", & - units="nondim", default=-1.0, do_not_log=.true.) - if (Stanley_coeff < 0.0) call MOM_error(FATAL, & - "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ML is true.") - endif - call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & - 'The value the von Karman constant as used for mixed layer viscosity.', & - units='nondim', default=0.41) - ! We use GV%nkml to distinguish between the old and new implementation of MLE. - ! The old implementation only works for the layer model with nkml>0. - if (GV%nkml==0) then - call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF2", CS%ml_restrat_coef2, & + ! These parameters are only used in the OM4-era version of Fox-Kemper + call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in ML restrat code.", default=.false.) + if (CS%use_stanley_ml) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ML is true.") + endif + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + ! We use GV%nkml to distinguish between the old and new implementation of MLE. + ! The old implementation only works for the layer model with nkml>0. + if (GV%nkml==0) then + call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF2", CS%ml_restrat_coef2, & "As for FOX_KEMPER_ML_RESTRAT_COEF but used in a second application "//& "of the MLE restratification parameterization.", units="nondim", default=0.0) - call get_param(param_file, mdl, "MLE_FRONT_LENGTH", CS%front_length, & + call get_param(param_file, mdl, "MLE_FRONT_LENGTH", CS%front_length, & "If non-zero, is the frontal-length scale used to calculate the "//& "upscaling of buoyancy gradients that is otherwise represented "//& "by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is "//& "non-zero, it is recommended to set FOX_KEMPER_ML_RESTRAT_COEF=1.0.",& units="m", default=0.0, scale=US%m_to_L) - call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & "If true, the MLE parameterization will use the mixed-layer "//& "depth provided by the active PBL parameterization. If false, "//& "MLE will estimate a MLD based on a density difference with the "//& "surface using the parameter MLE_DENSITY_DIFF.", default=.false.) - call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & "The time-scale for a running-mean filter applied to the mixed-layer "//& "depth used in the MLE restratification parameterization. When "//& "the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0., scale=US%s_to_T) - call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & "The time-scale for a running-mean filter applied to the filtered "//& "mixed-layer depth used in a second MLE restratification parameterization. "//& "When the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0., scale=US%s_to_T) - if (.not. CS%MLE_use_PBL_MLD) then - call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & + if (.not. CS%MLE_use_PBL_MLD) then + call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & "Density difference used to detect the mixed-layer "//& "depth used for the mixed-layer eddy parameterization "//& "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) - endif - call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & + endif + call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& "depth used for a smoother stream function at the base of "//& "the mixed-layer.", units="nondim", default=0.0) - call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & + call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & "A scaling coefficient for stretching/shrinking the MLD "//& "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) - endif - call get_param(param_file, mdl, "KV_RESTRAT", CS%Kv_restrat, & + endif + call get_param(param_file, mdl, "KV_RESTRAT", CS%Kv_restrat, & "A small viscosity that sets a floor on the momentum mixing rate during "//& "restratification. If this is positive, it will prevent some possible "//& "divisions by zero even if ustar, RESTRAT_USTAR_MIN, and f are all 0.", & units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) - call get_param(param_file, mdl, "OMEGA", omega, & + call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & units="s-1", default=7.2921e-5, scale=US%T_to_s) - ustar_min_dflt = 2.0e-4 * omega * (GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) - call get_param(param_file, mdl, "RESTRAT_USTAR_MIN", CS%ustar_min, & + ustar_min_dflt = 2.0e-4 * omega * (GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + call get_param(param_file, mdl, "RESTRAT_USTAR_MIN", CS%ustar_min, & "The minimum value of ustar that will be used by the mixed layer "//& "restratification module. This can be tiny, but if this is greater than 0, "//& "it will prevent divisions by zero when f and KV_RESTRAT are zero.", & units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=US%m_to_Z*US%T_to_s) + endif CS%diag => diag flux_to_kg_per_s = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T + if (CS%use_Bodner) then; BLD_units = US%Z_to_m + else; BLD_units = GV%H_to_m; endif CS%id_uhml = register_diag_field('ocean_model', 'uhml', diag%axesCuL, Time, & 'Zonal Thickness Flux to Restratify Mixed Layer', & @@ -996,10 +1455,13 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 'Mixed Layer Meridional Restratification Timescale', 's', conversion=US%T_to_s) CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', & - 'm', conversion=GV%H_to_m) + 'm', conversion=BLD_units) + CS%id_BLD = register_diag_field('ocean_model', 'BLD_restrat', diag%axesT1, Time, & + 'Boundary Layer Depth as used in the mixed-layer restratification parameterization', & + 'm', conversion=BLD_units) CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & - 'm s2', conversion=US%m_to_Z*(US%L_T_to_m_s**2)) + 'm s-2', conversion=US%m_to_Z*(US%L_T_to_m_s**2)) CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & 'Transport stream function amplitude for zonal restratification of mixed layer', & 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) @@ -1012,9 +1474,20 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%id_vml = register_diag_field('ocean_model', 'vml_restrat', diag%axesCv1, Time, & 'Surface meridional velocity component of mixed layer restratification', & 'm s-1', conversion=US%L_T_to_m_s) + if (CS%use_Bodner) then + CS%id_wpup = register_diag_field('ocean_model', 'MLE_wpup', diag%axesT1, Time, & + 'Vertical turbulent momentum flux in Bodner mixed layer restratificiation parameterization', & + 'm2 s-2', conversion=(US%Z_to_m*US%s_to_T)**2) + CS%id_ustar = register_diag_field('ocean_model', 'MLE_ustar', diag%axesT1, Time, & + 'Surface turbulent friction velicity, u*, in Bodner mixed layer restratificiation parameterization', & + 'm s-1', conversion=(US%Z_to_m*US%s_to_T)) + CS%id_bflux = register_diag_field('ocean_model', 'MLE_bflux', diag%axesT1, Time, & + 'Surface buoyancy flux, B0, in Bodner mixed layer restratificiation parameterization', & + 'm2 s-3', conversion=(US%Z_to_m**2*US%s_to_T**3)) + endif ! Rescale variables from restart files if the internal dimensional scalings have changed. - if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then + if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0. .or. CS%use_Bodner) then if (query_initialized(CS%MLD_filtered, "MLD_MLE_filtered", restart_CS) .and. & (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then H_rescale = 1.0 / GV%m_to_H_restart @@ -1023,7 +1496,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, enddo ; enddo endif endif - if (CS%MLE_MLD_decay_time2>0.) then + if (CS%MLE_MLD_decay_time2>0. .or. CS%use_Bodner) then if (query_initialized(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", restart_CS) .and. & (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then H_rescale = 1.0 / GV%m_to_H_restart @@ -1035,6 +1508,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! If MLD_filtered is being used, we need to update halo regions after a restart if (allocated(CS%MLD_filtered)) call pass_var(CS%MLD_filtered, G%domain) + if (allocated(CS%MLD_filtered_slow)) call pass_var(CS%MLD_filtered_slow, G%domain) end function mixedlayer_restrat_init @@ -1049,7 +1523,7 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! Local variables - logical :: mixedlayer_restrat_init + logical :: mixedlayer_restrat_init, use_Bodner ! Check to see if this module will be used call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & @@ -1060,19 +1534,28 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest units="s", default=0., scale=US%s_to_T, do_not_log=.true.) call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & units="s", default=0., scale=US%s_to_T, do_not_log=.true.) - if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then + call get_param(param_file, mdl, "MLE%USE_BODNER23", use_Bodner, & + default=.false., do_not_log=.true.) + if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0. .or. use_Bodner) then ! CS%MLD_filtered is used to keep a running mean of the PBL's actively mixed MLD. allocate(CS%MLD_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered", .false., restart_CS, & longname="Time-filtered MLD for use in MLE", & units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif - if (CS%MLE_MLD_decay_time2>0.) then + if (CS%MLE_MLD_decay_time2>0. .or. use_Bodner) then ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. allocate(CS%MLD_filtered_slow(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) - call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered_slow", .false., restart_CS, & + call register_restart_field(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", .false., restart_CS, & longname="Slower time-filtered MLD for use in MLE", & - units=get_thickness_units(GV), conversion=GV%H_to_MKS) + units=get_thickness_units(GV), conversion=GV%H_to_MKS) ! UNITS ARE WRONG -AJA + endif + if (use_Bodner) then + ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. + allocate(CS%wpup_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) + call register_restart_field(CS%wpup_filtered, "MLE_Bflux", .false., restart_CS, & + longname="Time-filtered vertical turbulent momentum flux for use in MLE", & + units='m2 s-2', conversion=(US%Z_to_m*US%s_to_T)**2 ) endif end subroutine mixedlayer_restrat_register_restarts @@ -1109,6 +1592,18 @@ logical function mixedlayer_restrat_unit_tests(verbose) if (.not. this_test) print '(a)',' Passed tests of mu(z)' mixedlayer_restrat_unit_tests = this_test + ! Tests of the two time-scale running mean function + this_test = & + test_answer(verbose, rmean2ts(3.,2.,0.,0.,3.), 3., 'rmean2ts(3,2,0,0,3)=3') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(1.,2.,0.,0.,3.), 1., 'rmean2ts(1,2,0,0,3)=1') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(4.,0.,3.,0.,1.), 1., 'rmean2ts(4,0,3,0,1)=1') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(0.,4.,0.,3.,1.), 3., 'rmean2ts(0,4,0,3,1)=3') + if (.not. this_test) print '(a)',' Passed tests of rmean2ts(s,f,g,d,dt)' + mixedlayer_restrat_unit_tests = mixedlayer_restrat_unit_tests .or. this_test + end function mixedlayer_restrat_unit_tests !> Returns true if any cell of u and u_true are not identical. Returns false otherwise. @@ -1128,7 +1623,8 @@ logical function test_answer(verbose, u, u_true, label, tol) if (abs(u - u_true) > tolerance) test_answer = .true. if (test_answer .or. verbose) then if (test_answer) then - print '(1p2e24.16,a,1pe24.16,a,x,a)',u,u_true,' err=',u-u_true,' < wrong',label + print '(3(a,1pe24.16),x,a,x,a)','computed =',u,' correct =',u_true, & + ' err=',u-u_true,' < wrong',label else print '(2(a,1pe24.16),x,a)','computed =',u,' correct =',u_true,label endif @@ -1140,14 +1636,15 @@ end function test_answer !! !! \section section_mle Mixed-layer eddy parameterization module !! -!! The subroutines in this file implement a parameterization of unresolved viscous +!! The subroutines in this module implement a parameterization of unresolved viscous !! mixed layer restratification of the mixed layer as described in Fox-Kemper et !! al., 2008, and whose impacts are described in Fox-Kemper et al., 2011. !! This is derived in part from the older parameterization that is described in !! Hallberg (Aha Hulikoa, 2003), which this new parameterization surpasses, which !! in turn is based on the sub-inertial mixed layer theory of Young (JPO, 1994). !! There is no net horizontal volume transport due to this parameterization, and -!! no direct effect below the mixed layer. +!! no direct effect below the mixed layer. A revised of the parameterization by +!! Bodner et al., 2023, is also available as an option. !! !! This parameterization sets the restratification timescale to agree with !! high-resolution studies of mixed layer restratification. @@ -1196,6 +1693,12 @@ end function test_answer !! \f$ C_e \f$ is hard-coded as 0.0625. \f$ \tau \f$ is calculated from the surface friction velocity \f$ u^* \f$. !! \todo Explain expression for momentum mixing time-scale. !! +!! | Symbol | Module parameter | +!! | ---------------------------- | --------------------- | +!! | \f$ \Gamma_\Delta \f$ | FOX_KEMPER_ML_RESTRAT | +!! | \f$ l_f \f$ | MLE_FRONT_LENGTH | +!! | \f$ \Delta \rho \f$ | MLE_DENSITY_DIFF | +!! !! \subsection section_mle_filtering Time-filtering of mixed-layer depth !! !! Using the instantaneous mixed-layer depth is inconsistent with the finite life-time of @@ -1207,6 +1710,10 @@ end function test_answer !! but to decay with time-scale \f$ \tau_h \f$. !! \f$ \bar{H} \f$ is substituted for \f$ H \f$ in the above equations. !! +!! | Symbol | Module parameter | +!! | ---------------------------- | --------------------- | +!! | \f$ \tau_h \f$ | MLE_MLD_DECAY_TIME | +!! !! \subsection section_mle_mld Defining the mixed-layer-depth !! !! If the parameter MLE_USE_PBL_MLD=True then the mixed-layer depth is defined/diagnosed by the @@ -1216,6 +1723,59 @@ end function test_answer !! as the depth of a given density difference, \f$ \Delta \rho \f$, with the surface where the !! density difference is the parameter MLE_DENSITY_DIFF. !! +!! \subsection The Bodner (2023) modification +!! +!! To use this variant of the parameterization, set MLE\%USE_BODNER23=True which then changes the +!! available parameters. +!! MLE_USE_PBL_MLD must be True to use the B23 modification. +!! +!! Bodner et al., 2023, (B23) use an expression for the frontal width which changes the scaling from \f$ H^2 \f$ +!! to \f$ h H^2 \f$: +!! \f[ +!! {\bf \Psi} = C_r \frac{\Delta s |f| \bar{h} \bar{H}^2 \nabla \bar{b} \times \hat{\bf z} } +!! { \left( m_*u_*^3 + n_* w_*^3 \right)^{2/3} } \mu(z) +!! \f] +!! (see eq. 27 of B23). +!! Here, the \f$h\f$ is the activate boundary layer depth, and \f$H\f$ is the mixed layer depth. +!! The denominator is an approximation of the vertical turbulent momentum flux \f$\overline{w'u'}\f$ (see +!! eq. 18 of B23) calculated from the surface friction velocity \f$u_*\f$, and from the surface buoyancy flux, +!! \f$B\f$, using the relation \f$ w_*^3 \sim -B h \f$. +!! An advantage of this form of "sub-meso" is the denominator is well behaved at the equator but we apply a +!! lower bound of \f$w_{min}^2\f$ to avoid division by zero under zero forcing. +!! As for the original Fox-Kemper parameterization, \f$\nabla \bar{b}\f$ is the buoyancy gradient averaged +!! over the mixed-layer. +!! +!! The instantaneous boundary layer depth, \f$h\f$, is time filtered primarily to remove the diurnal cycle: +!! \f[ +!! \bar{h} \leftarrow \max \left( +!! \min \left( h, \frac{ \Delta t h + \tau_{h+} \bar{h} }{ \Delta t + \tau_{h+} } \right), +!! \frac{ \Delta t h + \tau_{h-} \bar{h} }{ \Delta t + \tau_{h-} } \right) +!! \f] +!! Setting \f$ \tau_{h+}=0 \f$ means that when \f$ h>\bar{h} \f$ then \f$\bar{h}\leftarrow h\f$, i.e. the +!! effective (filtered) depth, \f$\bar{h}\f$, is instantly deepened. When \f$h<\bar{h}\f$ then the effective +!! depth shoals with time-scale \f$\tau_{h-}\f$. +!! +!! A second filter is applied to \f$\bar{h}\f$ to yield and effective "mixed layer depth", \f$\bar{H}\f$, +!! defined as the deepest the boundary layer over some time-scale \f$\tau_{H-}\f$: +!! \f[ +!! \bar{H} \leftarrow \max \left( +!! \min \left( \bar{h}, \frac{ \Delta t \bar{h} + \tau_{H+} \bar{H} }{ \Delta t + \tau_{H+} } \right), +!! \frac{ \Delta t \bar{h} + \tau_{h-} \bar{H} }{ \Delta t + \tau_{H-} } \right) +!! \f] +!! Again, setting \f$ \tau_{H+}=0 \f$ allows the effective mixed layer to instantly deepend to \f$ \bar{h} \f$. +!! +!! | Symbol | Module parameter | +!! | ---------------------------- | ------------------------- | +!! | \f$ C_r \f$ | MLE\%CR | +!! | \f$ n_* \f$ | MLE\%BODNER_NSTAR | +!! | \f$ m_* \f$ | MLE\%BODNER_MSTAR | +!! | \f$ w_* \f$ | MLE\%BODNER_MSTAR | +!! | \f$ w_{min}^2 \f$ | MLE\%MIN_WSTAR2 | +!! | \f$ \tau_{h+} \f$ | MLE\%BLD_GROWING_TFILTER | +!! | \f$ \tau_{h-} \f$ | MLE\%BLD_DECAYING_TFILTER | +!! | \f$ \tau_{H+} \f$ | MLE\%MLD_GROWING_TFILTER | +!! | \f$ \tau_{H-} \f$ | MLE\%BLD_DECAYING_TFILTER | +!! !! \subsection section_mle_ref References !! !! Fox-Kemper, B., Ferrari, R. and Hallberg, R., 2008: @@ -1233,11 +1793,9 @@ end function test_answer !! in global ocean climate simulations. Ocean Modell., 39(1), p61-78. !! https://doi.org/10.1016/j.ocemod.2010.09.002 !! -!! | Symbol | Module parameter | -!! | ---------------------------- | --------------------- | -!! | \f$ \Gamma_\Delta \f$ | FOX_KEMPER_ML_RESTRAT | -!! | \f$ l_f \f$ | MLE_FRONT_LENGTH | -!! | \f$ \tau_h \f$ | MLE_MLD_DECAY_TIME | -!! | \f$ \Delta \rho \f$ | MLE_DENSITY_DIFF | +!! A.S. Bodner, B. Fox-Kemper, L. Johnson, L. P. Van Roekel, J. C. McWilliams, P. P. Sullivan, P. S. Hall, +!! and J. Dong, 2023: Modifying the Mixed Layer Eddy Parameterization to Include Frontogenesis Arrest by +!! Boundary Layer Turbulence. J. Phys. Oceanogr., 53(1), p323-339. +!! https://doi.org/10.1175/JPO-D-21-0297.1 end module MOM_mixed_layer_restrat diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 44eed12295..d3670ebe5a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -712,6 +712,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif if (.not.CS%KPPisPassive) then !$OMP parallel do default(shared) @@ -854,6 +858,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call energetic_PBL_get_MLD(CS%ePBL, visc%MLD, G, US) call pass_var(visc%MLD, G%domain, halo=1) endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. do K=2,nz ; do j=js,je ; do i=is,ie @@ -1306,6 +1314,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") if (CS%debug) then @@ -1391,6 +1403,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call energetic_PBL_get_MLD(CS%ePBL, visc%MLD, G, US) call pass_var(visc%MLD, G%domain, halo=1) endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. do K=2,nz ; do j=js,je ; do i=is,ie @@ -1900,6 +1916,10 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) endif + if (associated(visc%sfc_buoy_flx)) then + visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) + endif if (.not. CS%KPPisPassive) then !$OMP parallel do default(shared) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 1e3bf258d8..fb42c9a01a 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1870,7 +1870,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) ! Local variables logical :: use_kappa_shear, KS_at_vertex logical :: adiabatic, useKPP, useEPBL - logical :: use_CVMix_shear, MLE_use_PBL_MLD, use_CVMix_conv + logical :: use_CVMix_shear, MLE_use_PBL_MLD, MLE_use_Bodner, use_CVMix_conv integer :: isd, ied, jsd, jed, nz real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. character(len=40) :: mdl = "MOM_set_visc" ! This module's name. @@ -1942,6 +1942,15 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) endif + ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model + call get_param(param_file, mdl, "MLE%USE_BODNER23", MLE_use_Bodner, & + default=.false., do_not_log=.true.) + if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then + call safe_alloc_ptr(visc%sfc_buoy_flx, isd, ied, jsd, jed) + call register_restart_field(visc%sfc_buoy_flx, "SFC_BFLX", .false., restart_CS, & + "Instantaneous surface buoyancy flux", "m2 s-3", & + conversion=US%Z_to_m**2*US%s_to_T**3) + endif end subroutine set_visc_register_restarts From 8c46575c9b950ec05aad0a1b3cc6072d60f2ce4a Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 19 Apr 2023 09:32:02 -0400 Subject: [PATCH 34/91] Add Bodner MLE testing This patch adds the Bodner MLE testing parameters to the tc2.a test. --- .testing/tc2.a/MOM_tc_variant | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.testing/tc2.a/MOM_tc_variant b/.testing/tc2.a/MOM_tc_variant index d48fa53507..5a85c21aed 100644 --- a/.testing/tc2.a/MOM_tc_variant +++ b/.testing/tc2.a/MOM_tc_variant @@ -1,3 +1,9 @@ #override TOPO_CONFIG = "spoon" #override REMAPPING_SCHEME = "PPM_H4" #override REGRIDDING_COORDINATE_MODE = "SIGMA" +MLE_USE_PBL_MLD = True +MLE%USE_BODNER23 = True +MLE%BLD_DECAYING_TFILTER = 86400. +MLE%MLD_DECAYING_TFILTER = 259200. +MLE%BLD_GROWING_TFILTER = 300. +MLE%MLD_GROWING_TFILTER = 3600. From 76634ef7d5359c27ad7f28045d4ba6ca88df1bde Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Mar 2023 15:13:27 -0400 Subject: [PATCH 35/91] +Add Pa_to_RL2_T2 and Pa_to_RLZ_T2 to US type Add the combined unit scaling factors Pa_to_RL2_T2 and Pa_to_RLZ_T2 to the unit_scale_type to rescale pressures and wind stresses. All answers are bitwise identical, but there are two new elements in a public type. --- src/framework/MOM_unit_scaling.F90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index bfc2189188..6f9a7a5f5f 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -30,10 +30,10 @@ module MOM_unit_scaling real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density [R m3 kg-1 ~> 1] real :: Q_to_J_kg !< A constant that translates the units of enthalpy to Joules per kilogram [J kg-1 Q-1 ~> 1] real :: J_kg_to_Q !< A constant that translates Joules per kilogram to the units of enthalpy [Q kg J-1 ~> 1] - real :: C_to_degC !< A constant that translates the units of temperature to degrees Celsius [degC C-1 ~> 1] - real :: degC_to_C !< A constant that translates degrees Celsius to the units of temperature [C degC-1 ~> 1] - real :: S_to_ppt !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] - real :: ppt_to_S !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] + real :: C_to_degC !< A constant that translates the units of temperature to degrees Celsius [degC C-1 ~> 1] + real :: degC_to_C !< A constant that translates degrees Celsius to the units of temperature [C degC-1 ~> 1] + real :: S_to_ppt !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] + real :: ppt_to_S !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] ! These are useful combinations of the fundamental scale conversion factors above. real :: Z_to_L !< Convert vertical distances to lateral lengths [L Z-1 ~> 1] @@ -52,7 +52,8 @@ module MOM_unit_scaling real :: RZ3_T3_to_W_m2 !< Convert turbulent kinetic energy fluxes from R Z3 T-3 to W m-2 [W T3 R-1 Z-3 m-2 ~> 1] real :: W_m2_to_RZ3_T3 !< Convert turbulent kinetic energy fluxes from W m-2 to R Z3 T-3 [R Z3 m2 T-3 W-1 ~> 1] real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa [Pa T2 R-1 L-2 ~> 1] - ! Not used enough: real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2 [R L2 T-2 Pa-1 ~> 1] + real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2 [R L2 T-2 Pa-1 ~> 1] + real :: Pa_to_RLZ_T2 !< Convert wind stresses from Pa to R L Z T-2 [R L Z T-2 Pa-1 ~> 1] ! These are used for changing scaling across restarts. real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. @@ -218,8 +219,9 @@ subroutine set_unit_scaling_combos(US) US%QRZ_T_to_W_m2 = US%Q_to_J_kg * US%R_to_kg_m3 * US%Z_to_m * US%s_to_T ! Pressures: US%RL2_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 - ! It does not seem like US%Pa_to_RL2_T2 would be used enough in MOM6 to justify its existence. - ! US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 + US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 + ! Wind stresses: + US%Pa_to_RLZ_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 * US%L_to_Z end subroutine set_unit_scaling_combos From 6d08e02d10894f4659643b63b88b58c994a0ff19 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Mar 2023 15:40:49 -0400 Subject: [PATCH 36/91] Use US%Pa_to_RL2_T2 to rescale pressures Use the new combined unit scaling factor US%Pa_to_RL2_T2 to rescale input pressure fields and US%Pa_to_RLZ_T2 to rescale input wind stresses in various places in the MOM6 code, including in the solo_driver and FMS_cap drivers. Analogous changes could also be made to the mct and nuopc surface forcing files, but have been omitted for now. All answers are bitwise identical. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 34 +++++++++---------- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/user_surface_forcing.F90 | 4 +-- src/ALE/MOM_hybgen_regrid.F90 | 2 +- src/ALE/MOM_regridding.F90 | 6 ++-- src/core/MOM.F90 | 4 +-- src/core/MOM_PressureForce_FV.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 2 +- .../MOM_state_initialization.F90 | 2 +- src/tracer/MOM_neutral_diffusion.F90 | 2 +- src/user/Idealized_Hurricane.F90 | 6 ++-- src/user/dumbbell_surface_forcing.F90 | 2 +- 12 files changed, 33 insertions(+), 35 deletions(-) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index 88d2cb3f42..26ab6269ef 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -548,14 +548,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) enddo ; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) @@ -755,12 +755,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -911,7 +911,6 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] real :: taux2, tauy2 ! squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] - real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] logical :: do_ustar, do_gustless @@ -925,8 +924,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, i0 = is - index_bounds(1) ; j0 = js - index_bounds(3) IRho0 = US%L_to_Z / CS%Rho0 - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - stress_conversion = Pa_conversion * CS%wind_stress_multiplier + stress_conversion = US%Pa_to_RLZ_T2 * CS%wind_stress_multiplier do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) @@ -1037,15 +1035,15 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0)) ) & gustiness = CS%gust(i,j) endif - ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_conversion*IOB%stress_mag(i-i0,j-j0)) + ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif if (CS%answer_date < 20190101) then if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(Pa_conversion*US%L_to_Z*IOB%stress_mag(i-i0,j-j0) / CS%Rho0) + gustless_ustar(i,j) = sqrt(US%Pa_to_RLZ_T2*US%L_to_Z*IOB%stress_mag(i-i0,j-j0) / CS%Rho0) enddo ; enddo ; endif else if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(IRho0 * Pa_conversion*IOB%stress_mag(i-i0,j-j0)) + gustless_ustar(i,j) = sqrt(IRho0 * US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif endif elseif (wind_stagger == BGRID_NE) then @@ -1174,17 +1172,17 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces) real :: rDlon ! The magnitude of the change in longitude [degrees_E] and then its inverse [degrees_E-1] real :: cosA, sinA ! The cosine and sine of the angle between the grid and true north [nondim] real :: zonal_tau, merid_tau ! True zonal and meridional wind stresses [R Z L T-2 ~> Pa] - real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] logical :: overrode_x, overrode_y isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged overrode_x = .false. ; overrode_y = .false. - call data_override(G%Domain, 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x, scale=Pa_conversion) - call data_override(G%Domain, 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y, scale=Pa_conversion) + call data_override(G%Domain, 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, & + override=overrode_x, scale=US%Pa_to_RLZ_T2) + call data_override(G%Domain, 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, & + override=overrode_y, scale=US%Pa_to_RLZ_T2) if (overrode_x .or. overrode_y) then if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& @@ -1314,7 +1312,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "limit the water that can be frozen out of the ocean and "//& "the ice-ocean heat fluxes are treated explicitly. No "//& "limit is applied if a negative value is used.", & - units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=-1.0, scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "RESTORE_SALINITY", CS%restore_salt, & "If true, the coupled driver will add a globally-balanced "//& "fresh-water flux that drives sea-surface salinity "//& @@ -1532,8 +1530,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& @@ -1544,7 +1542,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! NOTE: There are certain cases where FMS is unable to read this file, so ! we use read_netCDF_data in place of MOM_read_data. call read_netCDF_data(gust_file, 'gustiness', CS%gust, G%Domain, & - rescale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa + rescale=US%Pa_to_RLZ_T2) ! units in file should be [Pa] endif call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index 12f1b6b78d..a3007326b7 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -242,7 +242,7 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", units="Pa", default=0.0, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index fc803c27e6..42e732bb73 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -78,7 +78,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! calculation of ustar - otherwise the lower bound would be Isq. do j=js,je ; do I=is-1,Ieq ! Change this to the desired expression. - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%Pa_to_RLZ_T2 enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. @@ -271,7 +271,7 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index f89e15d930..dc7c90a079 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -100,7 +100,7 @@ subroutine init_hybgen_regrid(CS, GV, US, param_file) "The pressure that is used for calculating the coordinate "//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & - units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "HYBGEN_MIN_THICKNESS", CS%min_thickness, & "The minimum layer thickness allowed when regridding with Hybgen.", & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index b9d74c01a2..8194176c15 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -530,7 +530,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif ! ensure CS%ref_pressure is rescaled properly - CS%ref_pressure = (US%kg_m3_to_R * US%m_s_to_L_T**2) * CS%ref_pressure + CS%ref_pressure = US%Pa_to_RL2_T2 * CS%ref_pressure if (allocated(rho_target)) then call set_target_densities(CS, US%kg_m3_to_R*rho_target) @@ -552,13 +552,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "The pressure that is used for calculating the coordinate "//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & - units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) else call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), P_Ref, & "The pressure that is used for calculating the diagnostic coordinate "//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& "This is only used for the RHO coordinate.", & - units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) endif call get_param(param_file, mdl, create_coord_param(param_prefix, "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), & tmpReal, & diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 84eb5fc90a..7c2547d5e9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2198,7 +2198,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This is here in case these values are used inappropriately. use_frazil = .false. ; bound_salinity = .false. - CS%tv%P_Ref = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 + CS%tv%P_Ref = 2.0e7*US%Pa_to_RL2_T2 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & "If true, water freezes if it gets too cold, and the "//& @@ -2234,7 +2234,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "The pressure that is used for calculating the coordinate "//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & - units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) if (bulkmixedlayer) then call get_param(param_file, "MOM", "NKML", nkml, & diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index dfacb40001..14c9b2e6dc 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -188,7 +188,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ p(i,j,1) = p_atm(i,j) enddo ; enddo else - ! oneatm = 101325.0 * US%kg_m3_to_R * US%m_s_to_L_T**2 ! 1 atm scaled to [R L2 T-2 ~> Pa] + ! oneatm = 101325.0 * US%Pa_to_RL2_T2 ! 1 atm scaled to [R L2 T-2 ~> Pa] !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 p(i,j,1) = 0.0 ! or oneatm diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ff65a3b60b..4f5e95cc26 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -635,7 +635,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_rhopot0 > 0) call post_data(CS%id_rhopot0, Rcv, CS%diag) endif if (CS%id_rhopot2 > 0) then - pressure_1d(:) = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 ! 2000 dbars + pressure_1d(:) = 2.0e7*US%Pa_to_RL2_T2 ! 2000 dbars !$OMP parallel do default(shared) do k=1,nz ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index bd0931c694..3975cd49ab 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1262,7 +1262,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) if (just_read) return ! All run-time parameters have been read, so return. call MOM_read_data(filename, p_surf_var, p_surf, G%Domain, & - scale=scale_factor*US%kg_m3_to_R*US%m_s_to_L_T**2) + scale=scale_factor*US%Pa_to_RL2_T2) if (use_remapping) then allocate(remap_CS) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index a34c2a2e58..479713863f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -167,7 +167,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & "The reference pressure (Pa) used for the derivatives of "//& "the equation of state. If negative (default), local pressure is used.", & - units="Pa", default=-1., scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=-1., scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & "If true, only applies neutral diffusion in the ocean interior."//& "That is, the algorithm will exclude the surface and bottom"//& diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 0d2926798f..ad930911ca 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -102,7 +102,7 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) ! Local variables real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: C + real :: C ! A temporary variable [nondim] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: answers_2018 ! If true, use expressions driving the idealized hurricane test @@ -132,10 +132,10 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) units='kg/m3', default=1.2, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "IDL_HURR_AMBIENT_PRESSURE", CS%pressure_ambient, & "Ambient pressure used in the idealized hurricane wind profile.", & - units='Pa', default=101200., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) + units='Pa', default=101200., scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", CS%pressure_central, & "Central pressure used in the idealized hurricane wind profile.", & - units='Pa', default=96800., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) + units='Pa', default=96800., scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & CS%rad_max_wind, "Radius of maximum winds used in the "//& "idealized hurricane wind profile.", & diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 4ac5ab3bf9..ca383ba1f1 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -210,7 +210,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DUMBBELL_SLP_AMP", CS%slp_amplitude, & "Amplitude of SLP forcing in reservoirs.", & - units="Pa", default=10000.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=10000.0, scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & units="days", default=1.0) From c32be04711df4fc2ecc2357339143b9b7ba8778a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Mar 2023 15:48:05 -0400 Subject: [PATCH 37/91] +Add runtime parameter TAUX_MAGNITUDE Added the new runtime parameter TAUX_MAGNITUDE to set the strength of the zonal wind stresses when WIND_CONFIG = "2gyre", "1gyre" or "Neverworld", with a default that matches the previous hard-coded dimensional parameters that were used to specify the wind stresses in these cases. Also use US%Pa_to_RLZ_T2 to rescale wind stresses throughout solo_driver/MOM_surface_forcing.F90. By default, all answers are bitwise identical, but there is a new runtime parameter in the MOM_parameter_doc files for some test cases. --- .../solo_driver/MOM_surface_forcing.F90 | 78 +++++++++---------- 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 092bc9e513..0e8aedb8d0 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -88,6 +88,8 @@ module MOM_surface_forcing !! forcing [R L Z T-2 ~> Pa] real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" !! forcing [R L Z T-2 ~> Pa] + real :: taux_mag !< Peak magnitude of the zonal wind stress for several analytic + !! profiles [R L Z T-2 ~> Pa] real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file @@ -426,8 +428,6 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] real :: PI ! A common irrational number, 3.1415926535... [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -435,13 +435,11 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z PI = 4.0*atan(1.0) ! Set the steady surface wind stresses, in units of [R L Z T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = 0.1 * Pa_to_RLZ_T2 * & - (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) + forces%taux(I,j) = CS%taux_mag * (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) enddo ; enddo do J=js-1,Jeq ; do i=is,ie @@ -465,8 +463,6 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] real :: PI ! A common irrational number, 3.1415926535... [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -475,12 +471,10 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB PI = 4.0*atan(1.0) - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z ! Set the steady surface wind stresses, in units of [R Z L T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = -0.2 * Pa_to_RLZ_T2 * & - cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) + forces%taux(I,j) = CS%taux_mag * cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) enddo ; enddo do J=js-1,Jeq ; do i=is,ie @@ -553,8 +547,6 @@ subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] real :: PI ! A common irrational number, 3.1415926535... [nondim] real :: y ! The latitude relative to the south normalized by the domain extent [nondim] real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] @@ -574,9 +566,9 @@ subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. PI = 4.0*atan(1.0) - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + forces%taux(:,:) = 0.0 - tau_max = 0.2 * Pa_to_RLZ_T2 + tau_max = CS%taux_mag off = 0.02 do j=js,je ; do I=is-1,Ieq y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat @@ -672,8 +664,6 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) character(len=200) :: filename ! The name of the input file. real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R L Z T-2 ~> Pa] real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R L Z T-2 ~> Pa] - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and monthly cycles. integer :: time_lev ! The time level that is used for a field. @@ -684,7 +674,6 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z call get_time(day, seconds, days) time_lev_daily = days - 365*floor(real(days) / 365.0) @@ -723,7 +712,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev, scale=Pa_to_RLZ_T2) + timelevel=time_lev, scale=US%Pa_to_RLZ_T2) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=js,je ; do I=is-1,Ieq @@ -757,7 +746,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), & G%Domain_aux, stagger=CGRID_NE, timelevel=time_lev, & - scale=Pa_to_RLZ_T2) + scale=US%Pa_to_RLZ_T2) do j=js,je ; do i=is,ie forces%taux(I,j) = CS%wind_scale * temp_x(I,j) forces%tauy(i,J) = CS%wind_scale * temp_y(i,J) @@ -767,7 +756,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & forces%taux(:,:), forces%tauy(:,:), & G%Domain, stagger=CGRID_NE, timelevel=time_lev, & - scale=Pa_to_RLZ_T2) + scale=US%Pa_to_RLZ_T2) if (CS%wind_scale /= 1.0) then do j=js,je ; do I=Isq,Ieq @@ -826,8 +815,6 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R Z L T-2 ~> Pa]. real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R Z L T-2 ~> Pa]. - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] integer :: i, j call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") @@ -838,12 +825,10 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) CS%dataOverrideIsInitialized = .True. endif - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 ! CS%wind_scale is ignored here because it is not set in this mode. - call data_override(G%Domain, 'taux', temp_x, day, scale=Pa_to_RLZ_T2) - call data_override(G%Domain, 'tauy', temp_y, day, scale=Pa_to_RLZ_T2) + call data_override(G%Domain, 'taux', temp_x, day, scale=US%Pa_to_RLZ_T2) + call data_override(G%Domain, 'tauy', temp_y, day, scale=US%Pa_to_RLZ_T2) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=G%jsc,G%jec ; do I=G%isc-1,G%IecB forces%taux(I,j) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) @@ -853,7 +838,7 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) enddo ; enddo if (CS%read_gust_2d) then - call data_override(G%Domain, 'gust', CS%gust, day, scale=Pa_to_RLZ_T2) + call data_override(G%Domain, 'gust', CS%gust, day, scale=US%Pa_to_RLZ_T2) do j=G%jsc,G%jec ; do i=G%isc,G%iec forces%ustar(i,j) = sqrt((sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + & CS%gust(i,j)) * US%L_to_Z / CS%Rho0) @@ -1514,8 +1499,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! This include declares and sets the variable "version". # include "version_variable.h" real :: flux_const_default ! The unscaled value of FLUXCONST [m day-1] - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: answers_2018 ! If true, use the order of arithmetic and expressions that recover @@ -1538,8 +1521,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%diag => diag if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, '') call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & @@ -1562,6 +1543,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "If true, the buoyancy forcing varies in time after the "//& "initialization of the model.", default=.true.) + ! Determine parameters related to the buoyancy forcing. call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & "The character string that indicates how buoyancy forcing is specified. Valid "//& "options include (file), (data_override), (zero), (const), (linear), (MESO), "//& @@ -1704,6 +1686,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "through the sensible heat flux field. ", & units='W/m2', scale=US%W_m2_to_QRZ_T, fail_if_missing=.true.) endif + + ! Determine parameters related to the wind forcing. call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & "The character string that indicates how wind forcing is specified. Valid "//& "options include (file), (data_override), (2gyre), (1gyre), (gyres), (zero), "//& @@ -1737,17 +1721,17 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "With the gyres wind_config, the constant offset in the "//& "zonal wind stress profile: "//& " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "TAUX_SIN_AMP", CS%gyres_taux_sin_amp, & "With the gyres wind_config, the sine amplitude in the "//& "zonal wind stress profile: "//& " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "TAUX_COS_AMP", CS%gyres_taux_cos_amp, & "With the gyres wind_config, the cosine amplitude in "//& "the zonal wind stress profile: "//& " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & "With the gyres wind_config, the number of gyres in "//& "the zonal wind stress profile: "//& @@ -1785,8 +1769,24 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WIND_SCURVES_TAUX", CS%scurves_taux, & "A list of zonal wind stress values at latitudes "//& "WIND_SCURVES_LATS defining a piecewise scurve profile.", & - units="Pa", scale=Pa_to_RLZ_T2, fail_if_missing=.true.) + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) endif + if (trim(CS%wind_config) == "2gyre") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = 2gyre.", & + units="Pa", default=0.1, scale=US%Pa_to_RLZ_T2) + endif + if (trim(CS%wind_config) == "1gyre") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = 1gyre.", & + units="Pa", default=-0.2, scale=US%Pa_to_RLZ_T2) + endif + if (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = Neverworld.", & + units="Pa", default=0.2, scale=US%Pa_to_RLZ_T2) + endif + if ((trim(CS%wind_config) == "2gyre") .or. & (trim(CS%wind_config) == "1gyre") .or. & (trim(CS%wind_config) == "gyres") .or. & @@ -1854,7 +1854,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & default=.true.) @@ -1870,7 +1870,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! NOTE: There are certain cases where FMS is unable to read this file, so ! we use read_netCDF_data in place of MOM_read_data. call read_netCDF_data(filename, 'gustiness', CS%gust, G%Domain, & - rescale=Pa_to_RLZ_T2) ! units in file should be Pa + rescale=US%Pa_to_RLZ_T2) ! units in file should be [Pa] endif ! All parameter settings are now known. @@ -1889,10 +1889,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C elseif (trim(CS%wind_config) == "const") then call get_param(param_file, mdl, "CONST_WIND_TAUX", CS%tau_x0, & "With wind_config const, this is the constant zonal wind-stress", & - units="Pa", scale=Pa_to_RLZ_T2, fail_if_missing=.true.) + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) call get_param(param_file, mdl, "CONST_WIND_TAUY", CS%tau_y0, & "With wind_config const, this is the constant meridional wind-stress", & - units="Pa", scale=Pa_to_RLZ_T2, fail_if_missing=.true.) + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) elseif (trim(CS%wind_config) == "SCM_CVmix_tests" .or. & trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_surface_forcing_init(Time, G, param_file, CS%SCM_CVmix_tests_CSp) From f9897c80f3702d466582365585088c918e43875d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 23 Mar 2023 07:44:56 -0400 Subject: [PATCH 38/91] Correct MLD_EN_VALS rescaling Correct inconsistent dimensional rescaling of the input values of MLD_EN_VALS, setting them all to [R Z3 T-2 ~> J m-2] to reflect that these are energies associated with vertical turbulent mixing. This fixes a rescaling bug when these energies are set to non-default values at runtime, but all answers and output are bitwise identical when no rescaling is used. --- .../vertical/MOM_diabatic_aux.F90 | 4 +- .../vertical/MOM_diabatic_driver.F90 | 46 +++++++++---------- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index ba8ba0b805..5f7acd982b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -827,7 +827,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) type(ocean_grid_type), intent(in) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z L2 T-2 ~> J m-2] + real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z3 T-2 ~> J m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any @@ -884,7 +884,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. do iM=1,3 - PE_threshold(iM) = Mixing_Energy(iM)/GV%g_earth + PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) enddo do j=js,je ; do i=is,ie diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 44eed12295..46843303a2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -171,7 +171,7 @@ module MOM_diabatic_driver real :: MLDdensityDifference !< Density difference used to determine MLD_user [R ~> kg m-3] real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the !! average stratification at the base of the mixed layer [Z ~> m]. - real :: MLD_EN_VALS(3) !< Energy values for energy mixed layer diagnostics [R Z L2 T-2 ~> J m-2] + real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] !>@{ Diagnostic IDs integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed @@ -500,7 +500,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0)) then call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/),& - h, tv, G, GV, US, CS%MLD_EN_VALS, CS%diag) + h, tv, G, GV, US, CS%MLD_En_vals, CS%diag) endif if (CS%use_int_tides) then if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn_IGW(:,:,1),CS%diag) @@ -3184,22 +3184,22 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (use_temperature) then CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff", diag%axesTi, & Time, "Diffusive diapycnal temperature flux across interfaces", & - "degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) + units="degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) if (.not.CS%useALEalgorithm) then CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv", diag%axesTi, & Time, "Advective diapycnal temperature flux across interfaces", & - "degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) + units="degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) endif CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff", diag%axesTi, & Time, "Diffusive diapycnal salnity flux across interfaces", & - "psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) + units="psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) if (.not.CS%useALEalgorithm) then CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv", diag%axesTi, & Time, "Advective diapycnal salnity flux across interfaces", & - "psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) + units="psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) endif CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & - 'Mixed layer depth (delta rho = 0.03)', 'm', conversion=US%Z_to_m, & + 'Mixed layer depth (delta rho = 0.03)', units='m', conversion=US%Z_to_m, & cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & cmor_standard_name='ocean_mixed_layer_thickness_defined_by_sigma_t') CS%id_mlotstsq = register_diag_field('ocean_model', 'mlotstsq', diag%axesT1, Time, & @@ -3208,31 +3208,31 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di units='m2', conversion=US%Z_to_m**2) CS%id_MLD_0125 = register_diag_field('ocean_model', 'MLD_0125', diag%axesT1, Time, & 'Mixed layer depth (delta rho = 0.125)', 'm', conversion=US%Z_to_m) - call get_param(param_file, mdl, "MLD_EN_VALS", CS%MLD_EN_VALS, & + call get_param(param_file, mdl, "MLD_EN_VALS", CS%MLD_En_vals, & "The energy values used to compute MLDs. If not set (or all set to 0.), the "//& - "default will overwrite to 25., 2500., 250000.",units='J/m2', default=0., & - scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) - if ((CS%MLD_EN_VALS(1)==0.).and.(CS%MLD_EN_VALS(2)==0.).and.(CS%MLD_EN_VALS(3)==0.)) then - CS%MLD_EN_VALS = (/25.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2,& - 2500.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2,& - 250000.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2/) - endif - write(EN1,'(F10.2)') CS%MLD_EN_VALS(1)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 - write(EN2,'(F10.2)') CS%MLD_EN_VALS(2)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 - write(EN3,'(F10.2)') CS%MLD_EN_VALS(3)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 + "default will overwrite to 25., 2500., 250000.", & + units='J/m2', default=0., scale=US%W_m2_to_RZ3_T3*US%s_to_T) + if ((CS%MLD_En_vals(1)==0.).and.(CS%MLD_En_vals(2)==0.).and.(CS%MLD_En_vals(3)==0.)) then + CS%MLD_En_vals = (/ 25.*US%W_m2_to_RZ3_T3*US%s_to_T, & + 2500.*US%W_m2_to_RZ3_T3*US%s_to_T, & + 250000.*US%W_m2_to_RZ3_T3*US%s_to_T /) + endif + write(EN1,'(F10.2)') CS%MLD_En_vals(1)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN2,'(F10.2)') CS%MLD_En_vals(2)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN3,'(F10.2)') CS%MLD_En_vals(3)*US%RZ3_T3_to_W_m2*US%T_to_s CS%id_MLD_EN1 = register_diag_field('ocean_model', 'MLD_EN1', diag%axesT1, Time, & 'Mixed layer depth for energy value set to '//trim(EN1)//' J/m2 (Energy set by 1st MLD_EN_VALS)', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_MLD_EN2 = register_diag_field('ocean_model', 'MLD_EN2', diag%axesT1, Time, & 'Mixed layer depth for energy value set to '//trim(EN2)//' J/m2 (Energy set by 2nd MLD_EN_VALS)', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_MLD_EN3 = register_diag_field('ocean_model', 'MLD_EN3', diag%axesT1, Time, & 'Mixed layer depth for energy value set to '//trim(EN3)//' J/m2 (Energy set by 3rd MLD_EN_VALS)', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & - 'Squared buoyancy frequency below mixed layer', 's-2', conversion=US%s_to_T**2) + 'Squared buoyancy frequency below mixed layer', units='s-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & - 'Mixed layer depth (used defined)', 'm', conversion=US%Z_to_m) + 'Mixed layer depth (used defined)', units='m', conversion=US%Z_to_m) endif call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & "The density difference used to determine a diagnostic mixed "//& From 7225642b58c7514851a83f60a63e49175c1a9938 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Mar 2023 15:39:38 -0400 Subject: [PATCH 39/91] Add better error handling to read_var_sizes Add better error handling to read_var_sizes when a missing file or missing variable is provided as an argument. Without this change the model fails with a segmentation fault on line 768 of MOM_io.F90 if a bad file or variable name is provided. With this change, a useful error message is returned. All answers are bitwise identical in all cases that worked previously. --- src/framework/MOM_io.F90 | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 1026216426..727abda795 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -765,13 +765,13 @@ function num_timelevels(filename, varname, min_dims) result(n_time) call get_var_sizes(filename, varname, ndims, sizes, match_case=.false., caller="num_timelevels") - n_time = sizes(ndims) + if (ndims > 0) n_time = sizes(ndims) if (present(min_dims)) then if (ndims < min_dims-1) then write(msg, '(I3)') min_dims call MOM_error(WARNING, "num_timelevels: variable "//trim(varname)//" in file "//& - trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.") + trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.") n_time = -1 elseif (ndims == min_dims - 1) then n_time = 0 @@ -861,12 +861,18 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d ncid = ncid_in else call open_file_to_read(filename, ncid, success=success) - if (.not.success) return + if (.not.success) then + call MOM_error(WARNING, "Unsuccessfully attempted to open file "//trim(filename)) + return + endif endif ! Get the dimension sizes of the variable varname. call get_varid(varname, ncid, filename, varid, match_case=match_case, found=found) - if (.not.found) return + if (.not.found) then + call MOM_error(WARNING, "Could not find variable "//trim(varname)//" in file "//trim(filename)) + return + endif status = NF90_inquire_variable(ncid, varid, ndims=ndims) if (status /= NF90_NOERR) then From 4038d699c97b26563b68c93eab153adf36fef195 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Apr 2023 10:56:04 -0400 Subject: [PATCH 40/91] Checksum unrescaled non-Boussinesq thicknesses Redid the scaling of 52 checksum or check_redundant calls for thickness or transports to use the MKS counterparts of the thickness units (i.e., m and m3/s or kg/m2 and kg/s, depending on the Boussinesq approximation), rather than always rescaling them to m or m3/s. In Boussinesq mode, everything remains the same, but in non-Boussinesq mode, this means that the model's actual variable are being checksummed and not a version that is rescaled by division by the (meaningless?) Boussinesq reference density. All solutions are bitwise identical, but some debugging output will change in non-Boussinesq mode. --- src/core/MOM.F90 | 28 +++++++++++----------- src/core/MOM_barotropic.F90 | 16 ++++++------- src/core/MOM_checksum_packages.F90 | 6 ++--- src/core/MOM_dynamics_split_RK2.F90 | 18 +++++++-------- src/tracer/MOM_offline_main.F90 | 36 ++++++++++++++--------------- 5 files changed, 52 insertions(+), 52 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7c2547d5e9..c8573a2c06 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1229,7 +1229,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & .not.CS%thickness_diffuse_first) then - if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) + if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_MKS) if (CS%thickness_diffuse) then call cpu_clock_begin(id_clock_thick_diff) @@ -1238,7 +1238,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) - if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_m) + if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_MKS) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") @@ -1257,9 +1257,9 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! apply the submesoscale mixed layer restratification parameterization if (CS%mixedlayer_restrat) then if (CS%debug) then - call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) call uvchksum("Pre-mixedlayer_restrat uhtr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & @@ -1267,9 +1267,9 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call cpu_clock_end(id_clock_ml_restrat) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (CS%debug) then - call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_MKS) call uvchksum("Post-mixedlayer_restrat [uv]htr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) endif endif @@ -1329,9 +1329,9 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (CS%debug) then call cpu_clock_begin(id_clock_other) - call hchksum(h,"Pre-advection h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,"Pre-advection h", G%HI, haloshift=1, scale=GV%H_to_MKS) call uvchksum("Pre-advection uhtr", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1, scale=US%C_to_degC) if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1, scale=US%S_to_ppt) if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, "Pre-advection frazil", G%HI, haloshift=0, & @@ -1494,9 +1494,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (.not.CS%adiabatic) then if (CS%debug) then call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) @@ -1600,9 +1600,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%debug) then call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_MKS) call uvchksum("Post-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Post-diabatic ", u, v, & ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) @@ -2862,7 +2862,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! all examples. !### if (CS%debug) then call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_MKS) endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) @@ -2902,7 +2902,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%debug) then call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_MKS) if (use_temperature) then call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=1, scale=US%C_to_degC) call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=1, scale=US%S_to_ppt) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index bb77a99c4c..d6d4199212 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1661,15 +1661,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call uvchksum("BT [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=0, & scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, scale=US%L_T_to_m_s) - call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, scale=GV%H_to_m) + call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, scale=GV%H_to_MKS) call uvchksum("BT BT_force_[uv]", BT_force_u, BT_force_v, & CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) if (interp_eta_PF) then - call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_m) - call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) else - call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_m) - call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_MKS) + call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, scale=GV%H_to_MKS) endif call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, CS%debug_BT_HI, haloshift=0, & @@ -2396,7 +2396,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, write(mesg,'("BT step ",I4)') n call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & scale=US%L_T_to_m_s) - call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, scale=GV%H_to_m) + call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, scale=GV%H_to_MKS) endif if (GV%Boussinesq) then @@ -3573,9 +3573,9 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) scalar_pair=.true.) if (present(h_u) .and. present(h_v)) & call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & - symmetric=.true., omit_corners=.true., scale=GV%H_to_m, & + symmetric=.true., omit_corners=.true., scale=GV%H_to_MKS, & scalar_pair=.true.) - call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_MKS) endif end subroutine btcalc diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index bc908ee60c..4a9df04c4d 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -76,9 +76,9 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy call uvchksum(mesg//" [uv]", u, v, G%HI, haloshift=hs, symmetric=sym, & omit_corners=omit_corners, scale=scale_vel) - call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_m) + call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) call uvchksum(mesg//" [uv]h", uh, vh, G%HI, haloshift=hs, symmetric=sym, & - omit_corners=omit_corners, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + omit_corners=omit_corners, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) end subroutine MOM_state_chksum_5arg ! ============================================================================= @@ -111,7 +111,7 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric, sym = .false. ; if (present(symmetric)) sym = symmetric call uvchksum(mesg//" u", u, v, G%HI, haloshift=hs, symmetric=sym, & omit_corners=omit_corners, scale=US%L_T_to_m_s) - call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_m) + call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, scale=GV%H_to_MKS) end subroutine MOM_state_chksum_3arg ! ============================================================================= diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 74ab4e1f18..143006b49d 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -407,7 +407,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call MOM_state_chksum("Start predictor ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call check_redundant("Start predictor u ", u, v, G, unscale=US%L_T_to_m_s) - call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) endif dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) @@ -641,16 +641,16 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & - symmetric=sym, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) call MOM_state_chksum("Predictor 1 init", u, v, h, uh, vh, G, GV, US, haloshift=1, & symmetric=sym) call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) endif ! up <- up + dt_pred d/dz visc d/dz up @@ -776,10 +776,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) - call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) endif ! diffu = horizontal viscosity terms (u_av) @@ -868,9 +868,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("Corrector 1 [uv]", u, v, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, scale=GV%H_to_MKS) call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & - symmetric=sym, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) ! call MOM_state_chksum("Corrector 1", u, v, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & @@ -1063,7 +1063,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_MKS) ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) endif diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 2200a28c2b..ea6167a6b8 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -304,7 +304,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C enddo ; enddo ; enddo if (CS%debug) then - call hchksum(h_pre, "h_pre before transport", G%HI, scale=GV%H_to_m) + call hchksum(h_pre, "h_pre before transport", G%HI, scale=GV%H_to_MKS) call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI, scale=HL2_to_kg_scale) endif tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) @@ -345,7 +345,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C ! Do ALE remapping/regridding to allow for more advection to occur in the next iteration call pass_var(h_new,G%Domain) if (CS%debug) then - call hchksum(h_new,"h_new before ALE", G%HI, scale=GV%H_to_m) + call hchksum(h_new,"h_new before ALE", G%HI, scale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'Before ALE ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif @@ -370,7 +370,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C call cpu_clock_end(id_clock_ALE) if (CS%debug) then - call hchksum(h_new, "h_new after ALE", G%HI, scale=GV%H_to_m) + call hchksum(h_new, "h_new after ALE", G%HI, scale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'After ALE ', iter call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif @@ -412,7 +412,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C call pass_vector(uhtr, vhtr, G%Domain) if (CS%debug) then - call hchksum(h_pre, "h after offline_advection_ale", G%HI, scale=GV%H_to_m) + call hchksum(h_pre, "h after offline_advection_ale", G%HI, scale=GV%H_to_MKS) call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) call MOM_tracer_chkinv("After offline_advection_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -599,7 +599,7 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve if (CS%id_vhr>0) call post_data(CS%id_vhr, vhtr, CS%diag) if (CS%debug) then - call hchksum(h_pre, "h_pre after redistribute", G%HI, scale=GV%H_to_m) + call hchksum(h_pre, "h_pre after redistribute", G%HI, scale=GV%H_to_MKS) call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI, scale=HL2_to_kg_scale) call MOM_tracer_chkinv("after redistribute ", G, GV, h_new, CS%tracer_Reg) endif @@ -679,9 +679,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p call MOM_mesg("Applying tracer source, sinks, and vertical mixing") if (CS%debug) then - call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, scale=GV%H_to_m) - call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, scale=GV%H_to_m) - call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, scale=GV%H_to_m) + call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) call MOM_tracer_chkinv("Before offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -743,9 +743,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p endif if (CS%debug) then - call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, scale=GV%H_to_m) - call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, scale=GV%H_to_m) - call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, scale=GV%H_to_m) + call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, scale=GV%H_to_MKS) call MOM_tracer_chkinv("After offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif @@ -786,7 +786,7 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) enddo ; enddo if (CS%debug) then - call hchksum(h, "h before fluxes into ocean", G%HI, scale=GV%H_to_m) + call hchksum(h, "h before fluxes into ocean", G%HI, scale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes into ocean", G, GV, h, CS%tracer_reg) endif do m = 1,CS%tracer_reg%ntr @@ -796,7 +796,7 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt=update_h) enddo if (CS%debug) then - call hchksum(h, "h after fluxes into ocean", G%HI, scale=GV%H_to_m) + call hchksum(h, "h after fluxes into ocean", G%HI, scale=GV%H_to_MKS) call MOM_tracer_chkinv("After fluxes into ocean", G, GV, h, CS%tracer_reg) endif @@ -825,7 +825,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) call MOM_error(WARNING, "Negative freshwater fluxes with non-zero tracer concentration not supported yet") if (CS%debug) then - call hchksum(h, "h before fluxes out of ocean", G%HI, scale=GV%H_to_m) + call hchksum(h, "h before fluxes out of ocean", G%HI, scale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif do m = 1, CS%tracer_reg%ntr @@ -835,7 +835,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt = update_h) enddo if (CS%debug) then - call hchksum(h, "h after fluxes out of ocean", G%HI, scale=GV%H_to_m) + call hchksum(h, "h after fluxes out of ocean", G%HI, scale=GV%H_to_MKS) call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif @@ -1035,7 +1035,7 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%debug) then call uvchksum("[uv]htr before update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, scale=GV%H_to_m) + call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, scale=GV%H_to_MKS) call hchksum(CS%tv%T, "Temp before update_offline_fields", G%HI, scale=US%C_to_degC) call hchksum(CS%tv%S, "Salt before update_offline_fields", G%HI, scale=US%S_to_ppt) endif @@ -1077,7 +1077,7 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%debug) then call uvchksum("[uv]htr after ALE regridding/remapping of inputs", CS%uhtr, CS%vhtr, G%HI, & scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, scale=GV%H_to_m) + call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, scale=GV%H_to_MKS) endif endif @@ -1119,7 +1119,7 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) if (CS%debug) then call uvchksum("[uv]htr after update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & scale=US%L_to_m**2*GV%H_to_kg_m2) - call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, scale=GV%H_to_m) + call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, scale=GV%H_to_MKS) call hchksum(CS%tv%T, "Temp after update_offline_fields", G%HI, scale=US%C_to_degC) call hchksum(CS%tv%S, "Salt after update_offline_fields", G%HI, scale=US%S_to_ppt) endif From 6547b2a65f741772aec000721c8184c0920083fc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 Mar 2023 05:53:20 -0500 Subject: [PATCH 41/91] (*)Use conversion factor for masscello diagnostic Use a conversion factor to rescale the units of masscello, just like every other diagnostic. This does not change the diagnostic itself, but it changes the order of the rescaling and the vertical remapping of this diagnostic onto other coordinates (like z) or spatial averaging of this diagnostic, which can change values in the last bits for this diagnostic for Boussinesq models (but not for non-Boussinesq models, for which the conversion factor is an integer power of 2). As a result some of the diagnostics derived from masscello can differ and this commit nominally fails the TC testing for reproducibility across code versions. All solutions and primary diagnostics, however, are bitwise identical, and even the derived diagnostic calculations are mathematically equivalent. --- src/diagnostics/MOM_diagnostics.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 4f5e95cc26..cf8b042c14 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -324,12 +324,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! mass per area of grid cell (for Boussinesq, use Rho0) if (CS%id_masscello > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_kg_m2*h(i,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_masscello, work_3d, CS%diag) - !### If the registration call has conversion=GV%H_to_kg_m2, the mathematically equivalent form would be: - ! call post_data(CS%id_masscello, h, CS%diag) + call post_data(CS%id_masscello, h, CS%diag) endif ! mass of liquid ocean (for Bouss, use Rho0). The reproducing sum requires the use of MKS units. @@ -1638,7 +1633,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag convert_H = GV%H_to_MKS CS%id_masscello = register_diag_field('ocean_model', 'masscello', diag%axesTL, & - Time, 'Mass per unit area of liquid ocean grid cell', 'kg m-2', & !### , conversion=GV%H_to_kg_m2, & + Time, 'Mass per unit area of liquid ocean grid cell', 'kg m-2', conversion=GV%H_to_kg_m2, & standard_name='sea_water_mass_per_unit_area', v_extensive=.true.) CS%id_masso = register_scalar_field('ocean_model', 'masso', Time, & From 1444864910adc6c408ad39263a83edb46074b954 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Feb 2023 04:15:52 -0500 Subject: [PATCH 42/91] +Remove rescaling factors from restart files Remove the code to account for unit rescaling within the restart files. This rescaling within the restart files has not been used in the code since March, 2022, and the model will work with older restart files provided that they did not use dimensional rescaling, and even if they did they can be converted not to use rescaling with a short run with the older code that created them. Also removed the publicly visible routines fix_restart_scaling and eliminated the m_to_H_restart element of the verticalGrid_type; in any cases of non-standard code using this element, it should be replaced with 1.0. The various US%..._restart elements and fix_restart_unit_scaling are being retained for now because they are still being used in the SIS2 code. These changes significantly simplify the code, and they lead to a handful of constants that are always 1 not being included in the MOM6 restart files. All answers are bitwise identical, but a publicly visible interface has been eliminated, as has been an element (GV%m_to_H_restart) of a transparent type. --- src/core/MOM.F90 | 67 +------------------ src/core/MOM_barotropic.F90 | 14 ---- src/core/MOM_dynamics_split_RK2.F90 | 36 ---------- src/core/MOM_verticalGrid.F90 | 18 +---- src/framework/MOM_unit_scaling.F90 | 22 +++--- src/ice_shelf/MOM_ice_shelf.F90 | 34 ---------- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 19 ------ .../MOM_state_initialization.F90 | 12 ---- src/parameterizations/lateral/MOM_MEKE.F90 | 45 ------------- .../lateral/MOM_mixed_layer_restrat.F90 | 22 ------ .../vertical/MOM_set_viscosity.F90 | 42 ------------ src/tracer/boundary_impulse_tracer.F90 | 4 -- src/user/MOM_controlled_forcing.F90 | 49 -------------- 13 files changed, 16 insertions(+), 368 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c8573a2c06..6cef9a6b30 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -135,14 +135,12 @@ module MOM use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state use MOM_tracer_flow_control, only : tracer_flow_control_end, call_tracer_register_obc_segments use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init -use MOM_unit_scaling, only : unit_scaling_end, fix_restart_unit_scaling +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, unit_scaling_end use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state use MOM_variables, only : rotate_surface_state use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd -use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units use MOM_wave_interface, only : wave_parameters_CS, waves_end, waves_register_restarts use MOM_wave_interface, only : Update_Stokes_Drift @@ -1978,7 +1976,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & real :: conv2watt ! A conversion factor from temperature fluxes to heat ! fluxes [J m-2 H-1 C-1 ~> J m-3 degC-1 or J kg-1 degC-1] real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] - real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors character(len=48) :: S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -3117,16 +3114,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then - if (query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then - ! Test whether the dimensional rescaling has changed for heat content. - if ((US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart /= 0.0) .and. & - (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart /= 1.0) ) then - QRZ_rescale = 1.0 / (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) - do j=js,je ; do i=is,ie - CS%tv%frazil(i,j) = QRZ_rescale * CS%tv%frazil(i,j) - enddo ; enddo - endif - else + if (.not.query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then CS%tv%frazil(:,:) = 0.0 call set_initialized(CS%tv%frazil, "frazil", restart_CSp) endif @@ -3136,39 +3124,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%p_surf_prev_set = query_initialized(CS%p_surf_prev, "p_surf_prev", restart_CSp) if (CS%p_surf_prev_set) then - ! Test whether the dimensional rescaling has changed for pressure. - if ((US%kg_m3_to_R_restart*US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%s_to_T_restart**2 /= US%kg_m3_to_R_restart * US%m_to_L_restart**2) ) then - RL2_T2_rescale = US%s_to_T_restart**2 / (US%kg_m3_to_R_restart*US%m_to_L_restart**2) - do j=js,je ; do i=is,ie - CS%p_surf_prev(i,j) = RL2_T2_rescale * CS%p_surf_prev(i,j) - enddo ; enddo - endif - call pass_var(CS%p_surf_prev, G%domain) endif endif - if (use_ice_shelf .and. associated(CS%Hml)) then - if (query_initialized(CS%Hml, "hML", restart_CSp)) then - ! Test whether the dimensional rescaling has changed for depths. - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0) ) then - Z_rescale = 1.0 / US%m_to_Z_restart - do j=js,je ; do i=is,ie - CS%Hml(i,j) = Z_rescale * CS%Hml(i,j) - enddo ; enddo - endif - endif - endif - - if (query_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp)) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0) ) then - Z_rescale = 1.0 / US%m_to_Z_restart - do j=js,je ; do i=is,ie - CS%ave_ssh_ibc(i,j) = Z_rescale * CS%ave_ssh_ibc(i,j) - enddo ; enddo - endif - else + if (.not.query_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp)) then if (CS%split) then call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta, dZref=G%Z_ref) else @@ -3195,10 +3155,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! initialize stochastic physics call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) - !### This could perhaps go here instead of in finish_MOM_initialization? - ! call fix_restart_scaling(GV) - ! call fix_restart_unit_scaling(US) - call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) @@ -3226,11 +3182,6 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) ! Pointers for convenience G => CS%G ; GV => CS%GV ; US => CS%US - !### Move to initialize_MOM? - call fix_restart_scaling(GV, unscaled=.true.) - call fix_restart_unit_scaling(US, unscaled=.true.) - - if (CS%use_particles) then call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v) endif @@ -3382,18 +3333,6 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) endif ! Register scalar unit conversion factors. - call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., restart_CSp, & - "Height unit conversion factor", "Z meter-1") - call register_restart_field(GV%m_to_H_restart, "m_to_H", .false., restart_CSp, & - "Thickness unit conversion factor", "H meter-1") - call register_restart_field(US%m_to_L_restart, "m_to_L", .false., restart_CSp, & - "Length unit conversion factor", "L meter-1") - call register_restart_field(US%s_to_T_restart, "s_to_T", .false., restart_CSp, & - "Time unit conversion factor", "T second-1") - call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., restart_CSp, & - "Density unit conversion factor", "R m3 kg-1") - call register_restart_field(US%J_kg_to_Q_restart, "J_kg_to_Q", .false., restart_CSp, & - "Heat content unit conversion factor.", units="Q kg J-1") call register_restart_field(CS%first_dir_restart, "First_direction", .false., restart_CSp, & "Indicator of the first direction in split calculations.", "nondim") diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index d6d4199212..40f759f4b8 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4318,8 +4318,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! drag piston velocity. character(len=80) :: wave_drag_var ! The wave drag piston velocity variable ! name in wave_drag_file. - real :: vel_rescale ! A rescaling factor for horizontal velocity from the representation in - ! a restart file to the internal representation in this run. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. real :: det_de ! The partial derivative due to self-attraction and loading of the reference @@ -4788,8 +4786,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, dtbt_tmp = -1.0 if (query_initialized(CS%dtbt, "DTBT", restart_CS)) then dtbt_tmp = CS%dtbt - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) & - dtbt_tmp = (1.0 / US%s_to_T_restart) * CS%dtbt endif ! Estimate the maximum stable barotropic time step. @@ -4948,11 +4944,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do k=1,nz ; do J=js-1,je ; do i=is,ie CS%vbtav(i,J) = CS%vbtav(i,J) + CS%frhatv(i,J,k) * v(i,J,k) enddo ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%s_to_T_restart /= US%m_to_L_restart)) then - vel_rescale = US%s_to_T_restart / US%m_to_L_restart - do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif if (CS%gradual_BT_ICs) then @@ -4960,11 +4951,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%s_to_T_restart /= US%m_to_L_restart)) then - vel_rescale = US%s_to_T_restart / US%m_to_L_restart - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo endif endif ! Calculate other constants which are used for btstep. diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 143006b49d..9fb1a6b356 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1246,14 +1246,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! This include declares and sets the variable "version". # include "version_variable.h" character(len=48) :: thickness_units, flux_units, eta_rest_name - real :: H_rescale ! A rescaling factor for thicknesses from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] - real :: vel_rescale ! A rescaling factor for velocities from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] - real :: uH_rescale ! A rescaling factor for thickness transports from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] - real :: accel_rescale ! A rescaling factor for accelerations from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] type(group_pass_type) :: pass_av_h_uvh logical :: debug_truncations logical :: read_uv, read_h2 @@ -1410,9 +1402,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) enddo ; enddo ; enddo call set_initialized(CS%eta, trim(eta_rest_name), restart_CS) - elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then - H_rescale = 1.0 / GV%m_to_H_restart - do j=js,je ; do i=is,ie ; CS%eta(i,j) = H_rescale * CS%eta(i,j) ; enddo ; enddo endif ! Copy eta into an output array. do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo @@ -1427,17 +1416,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) call set_initialized(CS%diffu, "diffu", restart_CS) call set_initialized(CS%diffv, "diffv", restart_CS) - else - if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - (US%s_to_T_restart**2 /= US%m_to_L_restart) ) then - accel_rescale = US%s_to_T_restart**2 / US%m_to_L_restart - do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB - CS%diffu(I,j,k) = accel_rescale * CS%diffu(I,j,k) - enddo ; enddo ; enddo - do k=1,nz ; do J=G%JscB,G%JecB ; do i=is,ie - CS%diffv(i,J,k) = accel_rescale * CS%diffv(i,J,k) - enddo ; enddo ; enddo - endif endif if (.not. query_initialized(CS%u_av, "u2", restart_CS) .or. & @@ -1446,11 +1424,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = v(i,J,k) ; enddo ; enddo ; enddo call set_initialized(CS%u_av, "u2", restart_CS) call set_initialized(CS%v_av, "v2", restart_CS) - elseif ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - (US%s_to_T_restart /= US%m_to_L_restart) ) then - vel_rescale = US%s_to_T_restart / US%m_to_L_restart - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo - do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = vel_rescale * CS%v_av(i,J,k) ; enddo ; enddo ; enddo endif if (CS%store_CAu) then @@ -1504,15 +1477,6 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(CS%h_av, "h2", restart_CS)) then CS%h_av(:,:,:) = h(:,:,:) call set_initialized(CS%h_av, "h2", restart_CS) - elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then - H_rescale = 1.0 / GV%m_to_H_restart - do k=1,nz ; do j=js,je ; do i=is,ie ; CS%h_av(i,j,k) = H_rescale * CS%h_av(i,j,k) ; enddo ; enddo ; enddo - endif - if ( (GV%m_to_H_restart * US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - (US%s_to_T_restart /= (GV%m_to_H_restart * US%m_to_L_restart**2)) ) then - uH_rescale = US%s_to_T_restart / (GV%m_to_H_restart * US%m_to_L_restart**2) - do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB ; uh(I,j,k) = uH_rescale * uh(I,j,k) ; enddo ; enddo ; enddo - do k=1,nz ; do J=G%JscB,G%JecB ; do i=is,ie ; vh(i,J,k) = uH_rescale * vh(i,J,k) ; enddo ; enddo ; enddo endif endif endif diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index f20c7bbd26..d6003ca626 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -12,7 +12,7 @@ module MOM_verticalGrid #include public verticalGridInit, verticalGridEnd -public setVerticalGridAxes, fix_restart_scaling +public setVerticalGridAxes public get_flux_units, get_thickness_units, get_tr_flux_units ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -75,7 +75,7 @@ module MOM_verticalGrid real :: H_to_MKS !< A constant that translates thickness units to its MKS unit !! (m or kg m-2) based on GV%Boussinesq [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] - real :: m_to_H_restart = 0.0 !< A copy of the m_to_H that is used in restart files. + real :: m_to_H_restart = 1.0 !< A copy of the m_to_H that is used in restart files. end type verticalGrid_type contains @@ -187,20 +187,6 @@ subroutine verticalGridInit( param_file, GV, US ) end subroutine verticalGridInit -!> Set the scaling factors for restart files to the scaling factors for this run. -subroutine fix_restart_scaling(GV, unscaled) - type(verticalGrid_type), intent(inout) :: GV !< The ocean's vertical grid structure - logical, optional, intent(in) :: unscaled !< If true, set the restart factors as though the - !! model would be unscaled, which is appropriate if the - !! scaling is undone when writing a restart file. - - GV%m_to_H_restart = GV%m_to_H - if (present(unscaled)) then ; if (unscaled) then - GV%m_to_H_restart = 1.0 - endif ; endif - -end subroutine fix_restart_scaling - !> Returns the model's thickness units, usually m or kg/m^2. function get_thickness_units(GV) character(len=48) :: get_thickness_units !< The vertical thickness units diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 6f9a7a5f5f..482c2eec7a 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -55,12 +55,12 @@ module MOM_unit_scaling real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2 [R L2 T-2 Pa-1 ~> 1] real :: Pa_to_RLZ_T2 !< Convert wind stresses from Pa to R L Z T-2 [R L Z T-2 Pa-1 ~> 1] - ! These are used for changing scaling across restarts. - real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. - real :: m_to_L_restart = 0.0 !< A copy of the m_to_L that is used in restart files. - real :: s_to_T_restart = 0.0 !< A copy of the s_to_T that is used in restart files. - real :: kg_m3_to_R_restart = 0.0 !< A copy of the kg_m3_to_R that is used in restart files. - real :: J_kg_to_Q_restart = 0.0 !< A copy of the J_kg_to_Q that is used in restart files. + ! These are no longer used for changing scaling across restarts. + real :: m_to_Z_restart = 1.0 !< A copy of the m_to_Z that is used in restart files. + real :: m_to_L_restart = 1.0 !< A copy of the m_to_L that is used in restart files. + real :: s_to_T_restart = 1.0 !< A copy of the s_to_T that is used in restart files. + real :: kg_m3_to_R_restart = 1.0 !< A copy of the kg_m3_to_R that is used in restart files. + real :: J_kg_to_Q_restart = 1.0 !< A copy of the J_kg_to_Q that is used in restart files. end type unit_scale_type contains @@ -233,11 +233,11 @@ subroutine fix_restart_unit_scaling(US, unscaled) !! model would be unscaled, which is appropriate if the !! scaling is undone when writing a restart file. - US%m_to_Z_restart = US%m_to_Z - US%m_to_L_restart = US%m_to_L - US%s_to_T_restart = US%s_to_T - US%kg_m3_to_R_restart = US%kg_m3_to_R - US%J_kg_to_Q_restart = US%J_kg_to_Q + US%m_to_Z_restart = 1.0 ! US%m_to_Z + US%m_to_L_restart = 1.0 ! US%m_to_L + US%s_to_T_restart = 1.0 ! US%s_to_T + US%kg_m3_to_R_restart = 1.0 ! US%kg_m3_to_R + US%J_kg_to_Q_restart = 1.0 ! US%J_kg_to_Q if (present(unscaled)) then ; if (unscaled) then US%m_to_Z_restart = 1.0 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a78c17803c..113b6c045b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1222,12 +1222,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, !! the ice-shelf state type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() - real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a restart file to the internal representation in this run. - real :: RZ_rescale ! A rescaling factor for mass loads from the representation in - ! a restart file to the internal representation in this run. - real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in - ! a restart file to the internal representation in this run. real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. @@ -1675,12 +1669,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif endif - call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & - "Height unit conversion factor", "Z meter-1") - call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & - "Length unit conversion factor", "L meter-1") - call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & - "Density unit conversion factor", "R m3 kg-1") if (CS%active_shelf_dynamics) then call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & "ice sheet/shelf thickness mask" ,"none") @@ -1723,28 +1711,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, CS%restart_CSp) - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0)) then - Z_rescale = 1.0 / US%m_to_Z_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - ISS%h_shelf(i,j) = Z_rescale * ISS%h_shelf(i,j) - enddo ; enddo - endif - - if ((US%m_to_Z_restart*US%kg_m3_to_R_restart /= 0.0) .and. & - (US%m_to_Z_restart*US%kg_m3_to_R_restart /= 1.0)) then - RZ_rescale = 1.0 / (US%m_to_Z_restart * US%kg_m3_to_R_restart) - do j=G%jsc,G%jec ; do i=G%isc,G%iec - ISS%mass_shelf(i,j) = RZ_rescale * ISS%mass_shelf(i,j) - enddo ; enddo - endif - - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= 1.0)) then - L_rescale = 1.0 / US%m_to_L_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - ISS%area_shelf_h(i,j) = L_rescale**2 * ISS%area_shelf_h(i,j) - enddo ; enddo - endif - endif ! .not. new_sim ! do j=G%jsc,G%jec ; do i=G%isc,G%iec diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 3049cae00c..9b584ae0f9 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -330,10 +330,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ !! a solo ice-sheet driver. ! Local variables - real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a restart file to the internal representation in this run. - real :: vel_rescale ! A rescaling factor for horizontal velocities from the representation - ! in a restart file to the internal representation in this run. real :: T_shelf_bdry ! A default ice shelf temperature to use for ice flowing ! in through open boundaries [C ~> degC] !This include declares and sets the variable "version". @@ -485,21 +481,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Take additional initialization steps, for example of dependent variables. if (active_shelf_dynamics .and. .not.new_sim) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0)) then - Z_rescale = 1.0 / US%m_to_Z_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%OD_av(i,j) = Z_rescale * CS%OD_av(i,j) - enddo ; enddo - endif - - if ((US%m_to_L_restart*US%s_to_T_restart /= 0.0) .and. & - (US%m_to_L_restart /= US%s_to_T_restart)) then - vel_rescale = US%s_to_T_restart / US%m_to_L_restart - do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec - CS%u_shelf(I,J) = vel_rescale * CS%u_shelf(I,J) - CS%v_shelf(I,J) = vel_rescale * CS%v_shelf(I,J) - enddo ; enddo - endif ! this is unfortunately necessary; if grid is not symmetric the boundary values ! of u and v are otherwise not set till the end of the first linear solve, and so diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 3975cd49ab..fccb47e69f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -155,8 +155,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & character(len=200) :: config real :: H_rescale ! A rescaling factor for thicknesses from the representation in ! a restart file to the internal representation in this run [various units ~> 1] - real :: vel_rescale ! A rescaling factor for velocities from the representation in - ! a restart file to the internal representation in this run [various units ~> 1] real :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. logical :: from_Z_file, useALE @@ -529,16 +527,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "MOM6 attempted to restart from a file from a different time than given by Time_in.") Time = Time_in endif - if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then - H_rescale = 1.0 / GV%m_to_H_restart - do k=1,nz ; do j=js,je ; do i=is,ie ; h(i,j,k) = H_rescale * h(i,j,k) ; enddo ; enddo ; enddo - endif - if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - (US%s_to_T_restart /= US%m_to_L_restart) ) then - vel_rescale = US%s_to_T_restart / US%m_to_L_restart - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IeDB ; u(I,j,k) = vel_rescale * u(I,j,k) ; enddo ; enddo ; enddo - do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; v(i,J,k) = vel_rescale * v(i,J,k) ; enddo ; enddo ; enddo - endif endif if ( use_temperature ) then diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index add2d6a984..2a5cef5974 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1101,10 +1101,6 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, !! otherwise in tracer dynamics ! Local variables - real :: I_T_rescale ! A rescaling factor for time from the internal representation in this - ! run to the representation in a restart file, [nondim]? - real :: L_rescale ! A rescaling factor for length from the internal representation in this - ! run to the representation in a restart file, [nondim]? real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value [T ~> s] real :: cdrag ! The default bottom drag coefficient [nondim]. character(len=200) :: eke_filename, eke_varname, inputdir @@ -1439,47 +1435,6 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, if (CS%initialize) call MOM_error(WARNING, & "MEKE_init: Initializing MEKE with a local equilibrium balance.") - ! Account for possible changes in dimensional scaling for variables that have been - ! read from a restart file. - I_T_rescale = 1.0 - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) & - I_T_rescale = US%s_to_T_restart - L_rescale = 1.0 - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= 1.0)) & - L_rescale = 1.0 / US%m_to_L_restart - - if (L_rescale*I_T_rescale /= 1.0) then - if (allocated(MEKE%MEKE)) then ; if (query_initialized(MEKE%MEKE, "MEKE_MEKE", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%MEKE(i,j) = (L_rescale*I_T_rescale)**2 * MEKE%MEKE(i,j) - enddo ; enddo - endif ; endif - endif - if (L_rescale**2*I_T_rescale /= 1.0) then - if (allocated(MEKE%Kh)) then ; if (query_initialized(MEKE%Kh, "MEKE_Kh", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%Kh(i,j) = L_rescale**2*I_T_rescale * MEKE%Kh(i,j) - enddo ; enddo - endif ; endif - if (allocated(MEKE%Ku)) then ; if (query_initialized(MEKE%Ku, "MEKE_Ku", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%Ku(i,j) = L_rescale**2*I_T_rescale * MEKE%Ku(i,j) - enddo ; enddo - endif ; endif - if (allocated(MEKE%Kh_diff)) then ; if (query_initialized(MEKE%Kh, "MEKE_Kh_diff", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%Kh_diff(i,j) = L_rescale**2*I_T_rescale * MEKE%Kh_diff(i,j) - enddo ; enddo - endif ; endif - endif - if (L_rescale**4*I_T_rescale /= 1.0) then - if (allocated(MEKE%Au)) then ; if (query_initialized(MEKE%Au, "MEKE_Au", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%Au(i,j) = L_rescale**4*I_T_rescale * MEKE%Au(i,j) - enddo ; enddo - endif ; endif - endif - ! Set up group passes. In the case of a restart, these fields need a halo update now. if (allocated(MEKE%MEKE)) then call create_group_pass(CS%pass_MEKE, MEKE%MEKE, G%Domain) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index ffdf236152..6c072d21d5 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -849,8 +849,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure ! Local variables - real :: H_rescale ! A rescaling factor for thicknesses from the representation in - ! a restart file to the internal representation in this run [nondim]? real :: flux_to_kg_per_s ! A unit conversion factor for fluxes. [kg T s-1 H-1 L-2 ~> kg m-3 or 1] real :: omega ! The Earth's rotation rate [T-1 ~> s-1]. real :: ustar_min_dflt ! The default value for RESTRAT_USTAR_MIN [Z T-1 ~> m s-1] @@ -993,26 +991,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 'Surface meridional velocity component of mixed layer restratification', & 'm s-1', conversion=US%L_T_to_m_s) - ! Rescale variables from restart files if the internal dimensional scalings have changed. - if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then - if (query_initialized(CS%MLD_filtered, "MLD_MLE_filtered", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then - H_rescale = 1.0 / GV%m_to_H_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%MLD_filtered(i,j) = H_rescale * CS%MLD_filtered(i,j) - enddo ; enddo - endif - endif - if (CS%MLE_MLD_decay_time2>0.) then - if (query_initialized(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then - H_rescale = 1.0 / GV%m_to_H_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%MLD_filtered_slow(i,j) = H_rescale * CS%MLD_filtered_slow(i,j) - enddo ; enddo - endif - endif - ! If MLD_filtered is being used, we need to update halo regions after a restart if (allocated(CS%MLD_filtered)) call pass_var(CS%MLD_filtered, G%domain) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 1e3bf258d8..b38b4eea35 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2003,12 +2003,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS real :: Hbbl ! The static bottom boundary layer thickness [Z ~> m]. real :: BBL_thick_min ! The minimum bottom boundary layer thickness [Z ~> m]. - real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a restart file to the internal representation in this run [nondim]? - real :: I_T_rescale ! A rescaling factor for time from the internal representation in this run - ! to the representation in a restart file [nondim]? - real :: Z2_T_rescale ! A rescaling factor for vertical diffusivities and viscosities from the - ! representation in a restart file to the internal representation in this run [nondim]? integer :: i, j, k, is, ie, js, je integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. @@ -2317,42 +2311,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) call register_restart_field_as_obsolete('Kv_turb','Kv_shear', restart_CS) - ! Account for possible changes in dimensional scaling for variables that have been - ! read from a restart file. - Z_rescale = 1.0 - if (US%m_to_Z_restart /= 0.0) Z_rescale = 1.0 / US%m_to_Z_restart - I_T_rescale = 1.0 - if (US%s_to_T_restart /= 0.0) I_T_rescale = US%s_to_T_restart - Z2_T_rescale = Z_rescale**2*I_T_rescale - - if (Z2_T_rescale /= 1.0) then - if (associated(visc%Kd_shear)) then ; if (query_initialized(visc%Kd_shear, "Kd_shear", restart_CS)) then - do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_shear(i,j,k) = Z2_T_rescale * visc%Kd_shear(i,j,k) - enddo ; enddo ; enddo - endif ; endif - - if (associated(visc%Kv_shear)) then ; if (query_initialized(visc%Kv_shear, "Kv_shear", restart_CS)) then - do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kv_shear(i,j,k) = Z2_T_rescale * visc%Kv_shear(i,j,k) - enddo ; enddo ; enddo - endif ; endif - - if (associated(visc%Kv_shear_Bu)) then ; if (query_initialized(visc%Kv_shear_Bu, "Kv_shear_Bu", restart_CS)) then - do k=1,nz+1 ; do J=js-1,je ; do I=is-1,ie - visc%Kv_shear_Bu(I,J,k) = Z2_T_rescale * visc%Kv_shear_Bu(I,J,k) - enddo ; enddo ; enddo - endif ; endif - endif - - if (MLE_use_PBL_MLD .and. (Z_rescale /= 1.0)) then - if (associated(visc%MLD)) then ; if (query_initialized(visc%MLD, "MLD", restart_CS)) then - do j=js,je ; do i=is,ie - visc%MLD(i,j) = Z_rescale * visc%MLD(i,j) - enddo ; enddo - endif ; endif - endif - end subroutine set_visc_init !> This subroutine dellocates any memory in the set_visc control structure. diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 2a3727bdca..17c1f30525 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -189,10 +189,6 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, endif enddo ! Tracer loop - if (restart .and. (US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0) ) then - CS%remaining_source_time = (1.0 / US%s_to_T_restart) * CS%remaining_source_time - endif - if (associated(OBC)) then ! Steal from updated DOME in the fullness of time. endif diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index d218b4ea80..363a41f72f 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -525,8 +525,6 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) ! Local variables real :: smooth_len ! A smoothing lengthscale [L ~> m] - real :: RZ_T_rescale ! Unit conversion factor for precipiation [T kg m-2 s-1 R-1 Z-1 ~> 1] - real :: QRZ_T_rescale ! Unit conversion factor for head fluxes [T W m-2 Q-1 R-1 Z-1 ~> 1] logical :: do_integrated integer :: num_cycle integer :: i, j, isc, iec, jsc, jec, m @@ -601,53 +599,6 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) 'Control Corrective Precipitation', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) endif - ! Rescale if there are differences between the dimensional scaling of variables in - ! restart files from those in use for this run. - if ((US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart*US%s_to_T_restart /= 0.0) .and. & - (US%s_to_T_restart /= US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart) ) then - ! Redo the scaling of the corrective heat fluxes to [Q R Z T-1 ~> W m-2] - QRZ_T_rescale = US%s_to_T_restart / (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart) - - if (associated(CS%heat_0)) then - do j=jsc,jec ; do i=isc,iec - CS%heat_0(i,j) = QRZ_T_rescale * CS%heat_0(i,j) - enddo ; enddo - endif - - if ((CS%num_cycle > 0) .and. associated(CS%heat_cyc)) then - do m=1,CS%num_cycle ; do j=jsc,jec ; do i=isc,iec - CS%heat_cyc(i,j,m) = QRZ_T_rescale * CS%heat_cyc(i,j,m) - enddo ; enddo ; enddo - endif - endif - - if ((US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T_restart /= 0.0) .and. & - (US%s_to_T_restart /= US%kg_m3_to_R_restart * US%m_to_Z_restart) ) then - ! Redo the scaling of the corrective precipitation to [R Z T-1 ~> kg m-2 s-1] - RZ_T_rescale = US%s_to_T_restart / (US%kg_m3_to_R_restart * US%m_to_Z_restart) - - if (associated(CS%precip_0)) then - do j=jsc,jec ; do i=isc,iec - CS%precip_0(i,j) = RZ_T_rescale * CS%precip_0(i,j) - enddo ; enddo - endif - - if ((CS%num_cycle > 0) .and. associated(CS%precip_cyc)) then - do m=1,CS%num_cycle ; do j=jsc,jec ; do i=isc,iec - CS%precip_cyc(i,j,m) = RZ_T_rescale * CS%precip_cyc(i,j,m) - enddo ; enddo ; enddo - endif - endif - - if ((CS%num_cycle > 0) .and. associated(CS%avg_time) .and. & - ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) ) then - ! Redo the scaling of the accumulated times to [T ~> s] - do m=1,CS%num_cycle - CS%avg_time(m) = (1.0 / US%s_to_T_restart) * CS%avg_time(m) - enddo - endif - - end subroutine controlled_forcing_init !> Clean up this modules control structure. From f48bce7021718e9d3868082bffb517ab3e71e4d3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Feb 2023 10:24:38 -0500 Subject: [PATCH 43/91] +Add MOM_EOS_Wright_Full Added the new module MOM_EOS_Wright_full to enable the use of the version of the Wright equation of state that has been fit over the larger range of temperatures (-2 degC to 40 degC), salinities (0 psu to 40 psu) and pressures (0 dbar to 10000 dbar), than the does the restricted range fit in MOM_EOS_Wright, which had been fit over the range of (-2 degC to 30 degC), (28 psu to 38 psu) and (0 to 5000 dbar). Comments have been added to both modules to clearly document the range of properties over which they have been fitted. The new equation of state is enabled by setting EQN_OF_STATE = "WRIGHT_FULL". In addition, the default values for TFREEZE_FORM and EOS_QUADRATURE were changed depending on the equation of state to avoid having defaults that lead to fatal errors. All answers are bitwise identical in any cases that currently work, but there are new entries in the MOM_parameter_doc files. For now, only the coefficients have been changed between MOM_EOS_Wright and MOM_EOS_Wright_full, but this means that it does not yet have all of the parentheses that it should, as github.com/mom-ocean/MOM6/issues/1331 discusses. A follow up PR should add appropriate self-consistency and reference value checks (with a tolerance) for the various EOS routines, and then add enough parentheses to specify the order of arithmetic and hopefully enhance the accuracy. Ideally this can be done with the new equation of state before it starts to be widely used, so that we can avoid needing a extra code to reproduce the older answers. --- src/equation_of_state/MOM_EOS.F90 | 97 +- src/equation_of_state/MOM_EOS_Wright.F90 | 19 +- src/equation_of_state/MOM_EOS_Wright_full.F90 | 950 ++++++++++++++++++ 3 files changed, 1037 insertions(+), 29 deletions(-) create mode 100644 src/equation_of_state/MOM_EOS_Wright_full.F90 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 4ddedf85a8..a49cc39058 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -13,6 +13,11 @@ module MOM_EOS use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright use MOM_EOS_Wright, only : calculate_density_second_derivs_wright +use MOM_EOS_Wright_full, only : calculate_density_wright_full, calculate_spec_vol_wright_full +use MOM_EOS_Wright_full, only : calculate_density_derivs_wright_full +use MOM_EOS_Wright_full, only : calculate_specvol_derivs_wright_full, int_density_dz_wright_full +use MOM_EOS_Wright_full, only : calculate_compress_wright_full, int_spec_vol_dp_wright_full +use MOM_EOS_Wright_full, only : calculate_density_second_derivs_wright_full use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco use MOM_EOS_UNESCO, only : calculate_compress_unesco @@ -146,15 +151,18 @@ module MOM_EOS integer, parameter, public :: EOS_LINEAR = 1 !< A named integer specifying an equation of state integer, parameter, public :: EOS_UNESCO = 2 !< A named integer specifying an equation of state integer, parameter, public :: EOS_WRIGHT = 3 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_TEOS10 = 4 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_NEMO = 5 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT_FULL = 4 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_TEOS10 = 5 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_NEMO = 6 !< A named integer specifying an equation of state character*(10), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state character*(10), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state character*(10), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state +character*(12), parameter :: EOS_WRIGHT_RED_STRING = "WRIGHT_RED" !< A string for specifying the equation of state +character*(12), parameter :: EOS_WRIGHT_FULL_STRING = "WRIGHT_FULL" !< A string for specifying the equation of state character*(10), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state character*(10), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state -character*(10), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state +character*(12), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression integer, parameter :: TFREEZE_MILLERO = 2 !< A named integer specifying a freezing point expression @@ -163,7 +171,6 @@ module MOM_EOS character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" !< A string for specifying !! freezing point expression character*(10), parameter :: TFREEZE_TEOS10_STRING = "TEOS10" !< A string for specifying the freezing point expression -character*(10), parameter :: TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING !< The default freezing point expression contains @@ -242,6 +249,9 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r case (EOS_WRIGHT) call calculate_density_second_derivs_wright(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) + case (EOS_WRIGHT_FULL) + call calculate_density_second_derivs_wright_full(T_scale*T, S_scale*S, p_scale*pressure, & + d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) @@ -281,6 +291,8 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) case (EOS_WRIGHT) call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_WRIGHT_FULL) + call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) case (EOS_NEMO) @@ -333,6 +345,10 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_WRIGHT_FULL) + call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_wright_full(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & @@ -472,6 +488,10 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, call calculate_density_wright(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_wright(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) + case (EOS_WRIGHT_FULL) + call calculate_density_wright_full(Ta, Sa, pres, rho, is, npts, rho_reference) + call calculate_density_second_derivs_wright_full(Ta, Sa, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, is, npts) case (EOS_TEOS10) call calculate_density_teos10(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_teos10(Ta, Sa, pres, d2RdSS, d2RdST, & @@ -520,6 +540,8 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s call calculate_spec_vol_unesco(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_WRIGHT) call calculate_spec_vol_wright(T, S, pressure, specvol, start, npts, spv_ref) + case (EOS_WRIGHT_FULL) + call calculate_spec_vol_wright_full(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_TEOS10) call calculate_spec_vol_teos10(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_NEMO) @@ -807,6 +829,8 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_WRIGHT) call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_WRIGHT_FULL) + call calculate_density_derivs_wright_full(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_TEOS10) call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_NEMO) @@ -908,6 +932,8 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_WRIGHT) call calculate_density_derivs_wright(Ta, Sa, pres, drho_dT, drho_dS) + case (EOS_WRIGHT_FULL) + call calculate_density_derivs_wright_full(Ta, Sa, pres, drho_dT, drho_dS) case (EOS_TEOS10) call calculate_density_derivs_teos10(Ta, Sa, pres, drho_dT, drho_dS) case default @@ -967,6 +993,9 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_WRIGHT) call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_WRIGHT_FULL) + call calculate_density_second_derivs_wright_full(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -986,6 +1015,9 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_WRIGHT) call calculate_density_second_derivs_wright(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_WRIGHT_FULL) + call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1059,6 +1091,9 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr case (EOS_WRIGHT) call calculate_density_second_derivs_wright(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) + case (EOS_WRIGHT_FULL) + call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) @@ -1127,6 +1162,8 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start enddo case (EOS_WRIGHT) call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_WRIGHT_FULL) + call calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_TEOS10) call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_NEMO) @@ -1236,6 +1273,8 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) call calculate_compress_unesco(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_WRIGHT) call calculate_compress_wright(Ta, Sa, pres, rho, drho_dp, is, npts) + case (EOS_WRIGHT_FULL) + call calculate_compress_wright_full(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_TEOS10) call calculate_compress_teos10(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_NEMO) @@ -1369,6 +1408,11 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) + case (EOS_WRIGHT_FULL) + call int_spec_vol_dp_wright_full(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") end select @@ -1458,6 +1502,19 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & dz_neglect, useMassWghtInterp, Z_0p=Z_0p) endif + case (EOS_WRIGHT_FULL) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then + call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) + else + call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + endif case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") end select @@ -1481,15 +1538,17 @@ subroutine EOS_init(param_file, EOS, US) ! Local variables # include "version_variable.h" character(len=40) :: mdl = "MOM_EOS" ! This module's name. + character(len=12) :: TFREEZE_DEFAULT ! The default freezing point expression character(len=40) :: tmpstr + logical :: EOS_quad_default ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "EQN_OF_STATE", tmpstr, & - "EQN_OF_STATE determines which ocean equation of state "//& - "should be used. Currently, the valid choices are "//& - '"LINEAR", "UNESCO", "WRIGHT", "NEMO" and "TEOS10". '//& + "EQN_OF_STATE determines which ocean equation of state should be used. "//& + 'Currently, the valid choices are "LINEAR", "UNESCO", '//& + '"WRIGHT", "WRIGHT_RED", "WRIGHT_FULL", "NEMO" and "TEOS10". '//& "This is only used if USE_EOS is true.", default=EOS_DEFAULT) select case (uppercase(tmpstr)) case (EOS_LINEAR_STRING) @@ -1498,13 +1557,17 @@ subroutine EOS_init(param_file, EOS, US) EOS%form_of_EOS = EOS_UNESCO case (EOS_WRIGHT_STRING) EOS%form_of_EOS = EOS_WRIGHT + case (EOS_WRIGHT_RED_STRING) + EOS%form_of_EOS = EOS_WRIGHT + case (EOS_WRIGHT_FULL_STRING) + EOS%form_of_EOS = EOS_WRIGHT_FULL case (EOS_TEOS10_STRING) EOS%form_of_EOS = EOS_TEOS10 case (EOS_NEMO_STRING) EOS%form_of_EOS = EOS_NEMO case default call MOM_error(FATAL, "interpret_eos_selection: EQN_OF_STATE "//& - trim(tmpstr) // "in input file is invalid.") + trim(tmpstr) // " in input file is invalid.") end select call MOM_mesg('interpret_eos_selection: equation of state set to "' // & trim(tmpstr)//'"', 5) @@ -1525,10 +1588,16 @@ subroutine EOS_init(param_file, EOS, US) "salinity.", units="kg m-3 PSU-1", default=0.8) endif + EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & + (EOS%form_of_EOS == EOS_WRIGHT) .or. & + (EOS%form_of_EOS == EOS_WRIGHT_FULL)) call get_param(param_file, mdl, "EOS_QUADRATURE", EOS%EOS_quadrature, & "If true, always use the generic (quadrature) code "//& - "code for the integrals of density.", default=.false.) + "code for the integrals of density.", default=EOS_quad_default) + TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO)) & + TFREEZE_DEFAULT = TFREEZE_TEOS10_STRING call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & "TFREEZE_FORM determines which expression should be "//& "used for the freezing point. Currently, the valid "//& @@ -1563,10 +1632,10 @@ subroutine EOS_init(param_file, EOS, US) units="deg C Pa-1", default=0.0) endif - if ((EOS%form_of_EOS == EOS_TEOS10 .OR. EOS%form_of_EOS == EOS_NEMO) .AND. & - EOS%form_of_TFreeze /= TFREEZE_TEOS10) then - call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO \n" //& - "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO) .and. & + (EOS%form_of_TFreeze /= TFREEZE_TEOS10)) then + call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO "//& + "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") endif ! Unit conversions @@ -1806,5 +1875,5 @@ end module MOM_EOS !> \namespace mom_eos !! !! The MOM_EOS module is a wrapper for various equations of state (e.g. Linear, -!! Wright, UNESCO) and provides a uniform interface to the rest of the model +!! Wright, UNESCO, TEOS10 or NEMO) and provides a uniform interface to the rest of the model !! independent of which equation of state is being used. diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 77e0d17ff3..90bb631991 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -45,31 +45,20 @@ module MOM_EOS_Wright !> For a given thermodynamic state, return the derivatives of density with temperature and salinity interface calculate_density_derivs_wright module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright -end interface +end interface calculate_density_derivs_wright !> For a given thermodynamic state, return the second derivatives of density with various combinations !! of temperature, salinity, and pressure interface calculate_density_second_derivs_wright module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright -end interface +end interface calculate_density_second_derivs_wright -!>@{ Parameters in the Wright equation of state -!real :: a0, a1, a2, b0, b1, b2, b3, b4, b5, c0, c1, c2, c3, c4, c5 -! One of the two following blocks of values should be commented out. -! Following are the values for the full range formula. -! -!real, parameter :: a0 = 7.133718e-4, a1 = 2.724670e-7, a2 = -1.646582e-7 -!real, parameter :: b0 = 5.613770e8, b1 = 3.600337e6, b2 = -3.727194e4 -!real, parameter :: b3 = 1.660557e2, b4 = 6.844158e5, b5 = -8.389457e3 -!real, parameter :: c0 = 1.609893e5, c1 = 8.427815e2, c2 = -6.931554 -!real, parameter :: c3 = 3.869318e-2, c4 = -1.664201e2, c5 = -2.765195 +!>@{ Parameters in the Wright equation of state using the restricted range formula, which is a fit to the UNESCO +! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. - -! Following are the values for the reduced range formula. ! Note that a0/a1 ~= 2028 [degC] ; a0/a2 ~= -6343 [PSU] ! b0/b1 ~= 165 [degC] ; b0/b4 ~= 974 [PSU] ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -740 [PSU] - ! and also that (as always) [Pa] = [kg m-1 s-2] real, parameter :: a0 = 7.057924e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] real, parameter :: a1 = 3.480336e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] real, parameter :: a2 = -1.112733e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 new file mode 100644 index 0000000000..fec38656c0 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -0,0 +1,950 @@ +!> The equation of state using the Wright 1997 expressions +module MOM_EOS_Wright_full + +! This file is part of MOM6. See LICENSE.md for the license. + +!*********************************************************************** +!* The subroutines in this file implement the equation of state for * +!* sea water using the formulae given by Wright, 1997, J. Atmos. * +!* Ocean. Tech., 14, 735-740. Coded by R. Hallberg, 7/00. * +!*********************************************************************** + +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +#include + +public calculate_compress_wright_full, calculate_density_wright_full, calculate_spec_vol_wright_full +public calculate_density_derivs_wright_full, calculate_specvol_derivs_wright_full +public calculate_density_second_derivs_wright_full +public int_density_dz_wright_full, int_spec_vol_dp_wright_full + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + + +!> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to +!! a reference density, from salinity in practical salinity units ([PSU]), potential +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +interface calculate_density_wright_full + module procedure calculate_density_scalar_wright, calculate_density_array_wright +end interface calculate_density_wright_full + +!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect +!! to a reference specific volume, from salinity in practical salinity units ([PSU]), potential +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +interface calculate_spec_vol_wright_full + module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright +end interface calculate_spec_vol_wright_full + +!> For a given thermodynamic state, return the derivatives of density with temperature and salinity +interface calculate_density_derivs_wright_full + module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright +end interface calculate_density_derivs_wright_full + +!> For a given thermodynamic state, return the second derivatives of density with various combinations +!! of temperature, salinity, and pressure +interface calculate_density_second_derivs_wright_full + module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright +end interface calculate_density_second_derivs_wright_full + +!>@{ Parameters in the Wright equation of state using the full range formula, which is a fit to the UNESCO +! equation of state for the full range: -2 < theta < 40 [degC], 0 < S < 40 [PSU], 0 < p < 1e8 [Pa]. + + ! Note that a0/a1 ~= 2618 [degC] ; a0/a2 ~= -4333 [PSU] + ! b0/b1 ~= 156 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -741 [PSU] +real, parameter :: a0 = 7.133718e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 2.724670e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.646582e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.613770e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.600337e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -3.727194e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 1.660557e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 6.844158e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -8.389457e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.609893e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 8.427815e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -6.931554 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 3.869318e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -1.664201e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -2.765195 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] +!>@} + +contains + +!> This subroutine computes the in situ density of sea water (rho in +!! [kg m-3]) from salinity (S [PSU]), potential temperature +!! (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + +! *====================================================================* +! * This subroutine computes the in situ density of sea water (rho in * +! * [kg m-3]) from salinity (S [PSU]), potential temperature * +! * (T [degC]), and pressure [Pa]. It uses the expression from * +! * Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * +! * Coded by R. Hallberg, 7/00 * +! *====================================================================* + + real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: rho0 ! A 1-d array with a copy of the density [kg m-3] + + T0(1) = T + S0(1) = S + pressure0(1) = pressure + + call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1, rho_ref) + rho = rho0(1) + +end subroutine calculate_density_scalar_wright + +!> This subroutine computes the in situ density of sea water (rho in +!! [kg m-3]) from salinity (S [PSU]), potential temperature +!! (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(inout) :: rho !< in situ density [kg m-3]. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + integer :: j + + if (present(rho_ref)) pa_000 = (b0*(1.0 - a0*rho_ref) - rho_ref*c0) + if (present(rho_ref)) then ; do j=start,start+npts-1 + al_TS = a1*T(j) +a2*S(j) + al0 = a0 + al_TS + p_TSp = pressure(j) + (b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j)))) + lam_TS = c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) + + ! The following two expressions are mathematically equivalent. + ! rho(j) = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + rho(j) = (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + enddo ; else ; do j=start,start+npts-1 + al0 = (a0 + a1*T(j)) +a2*S(j) + p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*(b2 + b3*T(j)) + b5*S(j)) + lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*(c2 + c3*T(j)) + c5*S(j)) + rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + enddo ; endif + +end subroutine calculate_density_array_wright + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: spv0 ! A 1-d array with a copy of the specific volume [m3 kg-1] + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + + call calculate_spec_vol_array_wright(T0, S0, pressure0, spv0, 1, 1, spv_ref) + specvol = spv0(1) +end subroutine calculate_spec_vol_scalar_wright + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the + !! surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [m3 kg-1]. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + integer :: j + + do j=start,start+npts-1 + al0 = (a0 + a1*T(j)) +a2*S(j) + p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) + lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) + + if (present(spv_ref)) then + specvol(j) = (lambda + (al0 - spv_ref)*(pressure(j) + p0)) / (pressure(j) + p0) + else + specvol(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + endif + enddo +end subroutine calculate_spec_vol_array_wright + +!> For a given thermodynamic state, return the thermal/haline expansion coefficients +subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_dS, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the + !! surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(inout), dimension(:) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + integer :: j + + do j=start,start+npts-1 + al0 = (a0 + a1*T(j)) + a2*S(j) + p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) + lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) + + I_denom2 = 1.0 / (lambda + al0*(pressure(j) + p0)) + I_denom2 = I_denom2 *I_denom2 + drho_dT(j) = I_denom2 * & + (lambda* (b1 + T(j)*(2.0*b2 + 3.0*b3*T(j)) + b5*S(j)) - & + (pressure(j)+p0) * ( (pressure(j)+p0)*a1 + & + (c1 + T(j)*(c2*2.0 + c3*3.0*T(j)) + c5*S(j)) )) + drho_dS(j) = I_denom2 * (lambda* (b4 + b5*T(j)) - & + (pressure(j)+p0) * ( (pressure(j)+p0)*a2 + (c4 + c5*T(j)) )) + enddo + +end subroutine calculate_density_derivs_array_wright + +!> The scalar version of calculate_density_derivs which promotes scalar inputs to a 1-element array and then +!! demotes the output back to a scalar +subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_dS) + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1]. + + ! Local variables needed to promote the input/output scalars to 1-element arrays + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdt0 ! The derivative of density with temperature [kg m-3 degC-1] + real, dimension(1) :: drds0 ! The derivative of density with salinity [kg m-3 PSU-1] + + T0(1) = T + S0(1) = S + P0(1) = pressure + call calculate_density_derivs_array_wright(T0, S0, P0, drdt0, drds0, 1, 1) + drho_dT = drdt0(1) + drho_dS = drds0(1) + +end subroutine calculate_density_derivs_scalar_wright + +!> Second derivatives of density with respect to temperature, salinity, and pressure +subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] + real, dimension(:), intent(in ) :: S !< Salinity [PSU] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + + ! Local variables + real :: z0, z1 ! Local work variables [Pa] + real :: z2, z4 ! Local work variables [m2 s-2] + real :: z3, z5 ! Local work variables [Pa degC-1] + real :: z6, z8 ! Local work variables [m2 s-2 degC-1] + real :: z7 ! A local work variable [m2 s-2 PSU-1] + real :: z9 ! A local work variable [m3 kg-1] + real :: z10 ! A local work variable [Pa PSU-1] + real :: z11 ! A local work variable [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: z2_2 ! A local work variable [m4 s-4] + real :: z2_3 ! A local work variable [m6 s-6] + integer :: j + ! Based on the above expression with common terms factored, there probably exists a more numerically stable + ! and/or efficient expression + + do j = start,start+npts-1 + z0 = T(j)*(b1 + b5*S(j) + T(j)*(b2 + b3*T(j))) + z1 = (b0 + P(j) + b4*S(j) + z0) + z3 = (b1 + b5*S(j) + T(j)*(2.*b2 + 2.*b3*T(j))) + z4 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j)))) + z5 = (b1 + b5*S(j) + T(j)*(b2 + b3*T(j)) + T(j)*(b2 + 2.*b3*T(j))) + z6 = c1 + c5*S(j) + T(j)*(c2 + c3*T(j)) + T(j)*(c2 + 2.*c3*T(j)) + z7 = (c4 + c5*T(j) + a2*z1) + z8 = (c1 + c5*S(j) + T(j)*(2.*c2 + 3.*c3*T(j)) + a1*z1) + z9 = (a0 + a2*S(j) + a1*T(j)) + z10 = (b4 + b5*T(j)) + z11 = (z10*z4 - z1*z7) + z2 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j))) + z9*z1) + z2_2 = z2*z2 + z2_3 = z2_2*z2 + + drho_ds_ds(j) = (z10*(c4 + c5*T(j)) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T(j) + z9*z10 + a2*z1)*z11)/z2_3 + drho_ds_dt(j) = (z10*z6 - z1*(c5 + a2*z5) + b5*z4 - z5*z7)/z2_2 - (2.*(z6 + z9*z5 + a1*z1)*z11)/z2_3 + drho_dt_dt(j) = (z3*z6 - z1*(2.*c2 + 6.*c3*T(j) + a1*z5) + (2.*b2 + 4.*b3*T(j))*z4 - z5*z8)/z2_2 - & + (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 + drho_ds_dp(j) = (-c4 - c5*T(j) - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 + drho_dt_dp(j) = (-c1 - c5*S(j) - T(j)*(2.*c2 + 3.*c3*T(j)) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 + enddo + +end subroutine calculate_density_second_derivs_array_wright + +!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. Inputs +!! promoted to 1-element array and output demoted to scalar +subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Potential temperature referenced to 0 dbar + real, intent(in ) :: S !< Salinity [PSU] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 PSU-2] + real, dimension(1) :: drdsdt ! The second derivative of density with salinity and + ! temperature [kg m-3 PSU-1 degC-1] + real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] + real, dimension(1) :: drdsdp ! The second derivative of density with salinity and + ! pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(1) :: drdtdp ! The second derivative of density with temperature and + ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + T0(1) = T + S0(1) = S + P0(1) = P + call calculate_density_second_derivs_array_wright(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + drho_ds_ds = drdsds(1) + drho_ds_dt = drdsdt(1) + drho_dt_dt = drdtdt(1) + drho_ds_dp = drdsdp(1) + drho_dt_dp = drdtdp(1) + +end subroutine calculate_density_second_derivs_scalar_wright + +!> For a given thermodynamic state, return the partial derivatives of specific volume +!! with temperature and salinity +subroutine calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1]. + real, intent(inout), dimension(:) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + integer :: j + + do j=start,start+npts-1 +! al0 = (a0 + a1*T(j)) + a2*S(j) + p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) + lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) + + ! SV = al0 + lambda / (pressure(j) + p0) + + I_denom = 1.0 / (pressure(j) + p0) + dSV_dT(j) = (a1 + I_denom * (c1 + T(j)*((2.0*c2 + 3.0*c3*T(j))) + c5*S(j))) - & + (I_denom**2 * lambda) * (b1 + T(j)*((2.0*b2 + 3.0*b3*T(j))) + b5*S(j)) + dSV_dS(j) = (a2 + I_denom * (c4 + c5*T(j))) - & + (I_denom**2 * lambda) * (b4 + b5*T(j)) + enddo + +end subroutine calculate_specvol_derivs_wright_full + +!> This subroutine computes the in situ density of sea water (rho in [kg m-3]) +!! and the compressibility (drho/dp = C_sound^-2) (drho_dp [s2 m-2]) from +!! salinity (sal [PSU]), potential temperature (T [degC]), and pressure [Pa]. +!! It uses the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! Coded by R. Hallberg, 1/01 +subroutine calculate_compress_wright_full(T, S, pressure, rho, drho_dp, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: rho !< In situ density [kg m-3]. + real, intent(inout), dimension(:) :: 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 !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Coded by R. Hallberg, 1/01 + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + integer :: j + + do j=start,start+npts-1 + al0 = (a0 + a1*T(j)) +a2*S(j) + p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) + lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) + + I_denom = 1.0 / (lambda + al0*(pressure(j) + p0)) + rho(j) = (pressure(j) + p0) * I_denom + drho_dp(j) = lambda * I_denom * I_denom + enddo +end subroutine calculate_compress_wright_full + +!> This subroutine calculates analytical and nearly-analytical integrals of +!! pressure anomalies across layers, which are required for calculating the +!! finite-volume form pressure accelerations in a Boussinesq model. +subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] + real :: p_ave ! The layer averaged pressure [Pa] + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j) + p0_2d(i,j) = (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) + lambda_2d(i,j) = (c0 +c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + + dz = z_t(i,j) - z_b(i,j) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) + eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + +! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks + rem = I_Rho * (lambda * I_al0**2) * eps2 * & + (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dpa(i,j) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem) + if (present(intz_dpa)) & + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*g_Earth*rho_anom*dz**2 - dz*(1.0+eps)*rem) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) + eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) + eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + +end subroutine int_density_dz_wright_full + +!> This subroutine calculates 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 non-Boussinesq +!! model. There are essentially no free assumptions, apart from the use of +!! Boole's rule to do the horizontal integrals, and from a truncation in the +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! spv_ref, but this reduces the effects of roundoff. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate + !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = al0_scale * ( (a0 + a1s*T(i,j)) + a2s*S(i,j) ) + p0_2d(i,j) = p0_scale * ( (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) ) + lambda_2d(i,j) = lam_scale * ( (c0 + c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + alpha_anom = al0 + lambda / (p0 + p_ave) - spv_ref + rem = lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*(1.0-eps)*rem + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) + p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) + lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_wright_full + +end module MOM_EOS_Wright_full From 0f72e7fbdf980456ee116c5219226cc72e1a3959 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 Feb 2023 03:06:51 -0500 Subject: [PATCH 44/91] Fix and tidy Wright_EOS API documentation Cleaned up the comments describing the routines and added a proper doxygen namespace block at the end of the MOM_EOS_Wright and MOM_EOS_Wright_full modules, based on changes that A. Adcroft had on a detached branch of MOM6. Only comments are changed, and all answers are bitwise identical. --- src/equation_of_state/MOM_EOS_Wright.F90 | 134 +++++++++--------- src/equation_of_state/MOM_EOS_Wright_full.F90 | 128 +++++++++-------- 2 files changed, 135 insertions(+), 127 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 90bb631991..36180d14e8 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -3,12 +3,6 @@ module MOM_EOS_Wright ! This file is part of MOM6. See LICENSE.md for the license. -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the formulae given by Wright, 1997, J. Atmos. * -!* Ocean. Tech., 14, 735-740. Coded by R. Hallberg, 7/00. * -!*********************************************************************** - use MOM_hor_index, only : hor_index_type implicit none ; private @@ -20,16 +14,10 @@ module MOM_EOS_Wright public calculate_density_second_derivs_wright public int_density_dz_wright, int_spec_vol_dp_wright -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - - !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity in practical salinity units ([PSU]), potential !! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. interface calculate_density_wright module procedure calculate_density_scalar_wright, calculate_density_array_wright end interface calculate_density_wright @@ -37,23 +25,23 @@ module MOM_EOS_Wright !> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect !! to a reference specific volume, from salinity in practical salinity units ([PSU]), potential !! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. interface calculate_spec_vol_wright module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright end interface calculate_spec_vol_wright -!> For a given thermodynamic state, return the derivatives of density with temperature and salinity +!> Compute the derivatives of density with temperature and salinity interface calculate_density_derivs_wright module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright end interface calculate_density_derivs_wright -!> For a given thermodynamic state, return the second derivatives of density with various combinations +!> Compute the second derivatives of density with various combinations !! of temperature, salinity, and pressure interface calculate_density_second_derivs_wright module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright end interface calculate_density_second_derivs_wright -!>@{ Parameters in the Wright equation of state using the restricted range formula, which is a fit to the UNESCO +!>@{ Parameters in the Wright equation of state using the reduced range formula, which is a fit to the UNESCO ! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. ! Note that a0/a1 ~= 2028 [degC] ; a0/a2 ~= -6343 [PSU] @@ -78,10 +66,11 @@ module MOM_EOS_Wright contains -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the in situ density of sea water for scalar inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) real, intent(in) :: T !< Potential temperature relative to the surface [degC]. real, intent(in) :: S !< Salinity [PSU]. @@ -89,14 +78,7 @@ subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) real, intent(out) :: rho !< In situ density [kg m-3]. real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * [kg m-3]) from salinity (S [PSU]), potential temperature * -! * (T [degC]), and pressure [Pa]. It uses the expression from * -! * Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * -! * Coded by R. Hallberg, 7/00 * -! *====================================================================* - + ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] @@ -111,10 +93,11 @@ subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_wright -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. real, dimension(:), intent(in) :: S !< salinity [PSU]. @@ -124,7 +107,6 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ integer, intent(in) :: npts !< the number of values to calculate. real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. ! Local variables real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] real :: p0 ! The pressure offset in the Wright EOS [Pa] @@ -155,10 +137,11 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ end subroutine calculate_density_array_wright -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the Wright in situ specific volume of sea water for scalar inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) real, intent(in) :: T !< potential temperature relative to the surface [degC]. @@ -179,10 +162,11 @@ subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) specvol = spv0(1) end subroutine calculate_spec_vol_scalar_wright -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the Wright in situ specific volume of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, spv_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the @@ -213,7 +197,7 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, enddo end subroutine calculate_spec_vol_array_wright -!> For a given thermodynamic state, return the thermal/haline expansion coefficients +!> Return the thermal/haline expansion coefficients for 1-d array inputs and outputs subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_dS, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the !! surface [degC]. @@ -250,8 +234,10 @@ subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_d end subroutine calculate_density_derivs_array_wright -!> The scalar version of calculate_density_derivs which promotes scalar inputs to a 1-element array and then -!! demotes the output back to a scalar +!> Return the thermal/haline expansion coefficients for scalar inputs and outputs +!! +!! The scalar version of calculate_density_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_dS) real, intent(in) :: T !< Potential temperature relative to the surface [degC]. real, intent(in) :: S !< Salinity [PSU]. @@ -277,7 +263,7 @@ subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_ end subroutine calculate_density_derivs_scalar_wright -!> Second derivatives of density with respect to temperature, salinity, and pressure +!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp, start, npts) real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] @@ -337,8 +323,10 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh end subroutine calculate_density_second_derivs_array_wright -!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. Inputs -!! promoted to 1-element array and output demoted to scalar +!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. +!! +!! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp) real, intent(in ) :: T !< Potential temperature referenced to 0 dbar @@ -379,8 +367,8 @@ subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, dr end subroutine calculate_density_second_derivs_scalar_wright -!> For a given thermodynamic state, return the partial derivatives of specific volume -!! with temperature and salinity +!> Return the partial derivatives of specific volume with temperature and salinity +!! for 1-d array inputs and outputs subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. real, intent(in), dimension(:) :: S !< Salinity [PSU]. @@ -414,11 +402,7 @@ subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start end subroutine calculate_specvol_derivs_wright -!> This subroutine computes the in situ density of sea water (rho in [kg m-3]) -!! and the compressibility (drho/dp = C_sound^-2) (drho_dp [s2 m-2]) from -!! salinity (sal [PSU]), potential temperature (T [degC]), and pressure [Pa]. -!! It uses the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! Coded by R. Hallberg, 1/01 +!> Computes the compressibility of seawater for 1-d array inputs and outputs subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. real, intent(in), dimension(:) :: S !< Salinity [PSU]. @@ -430,7 +414,6 @@ subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. - ! Coded by R. Hallberg, 1/01 ! Local variables real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] real :: p0 ! The pressure offset in the Wright EOS [Pa] @@ -449,9 +432,11 @@ subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) enddo end subroutine calculate_compress_wright -!> This subroutine calculates analytical and nearly-analytical integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) @@ -707,12 +692,11 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & end subroutine int_density_dz_wright -!> This subroutine calculates 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 non-Boussinesq -!! model. There are essentially no free assumptions, apart from the use of -!! Boole's rule to do the horizontal integrals, and from a truncation in the -!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +!> Calculates 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 +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) @@ -947,4 +931,24 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_wright +!> \namespace mom_eos_wright +!! +!! \section section_EOS_Wright Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the reduced range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + end module MOM_EOS_Wright diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index fec38656c0..72aa38faf3 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -3,12 +3,6 @@ module MOM_EOS_Wright_full ! This file is part of MOM6. See LICENSE.md for the license. -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the formulae given by Wright, 1997, J. Atmos. * -!* Ocean. Tech., 14, 735-740. Coded by R. Hallberg, 7/00. * -!*********************************************************************** - use MOM_hor_index, only : hor_index_type implicit none ; private @@ -20,16 +14,10 @@ module MOM_EOS_Wright_full public calculate_density_second_derivs_wright_full public int_density_dz_wright_full, int_spec_vol_dp_wright_full -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - - !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity in practical salinity units ([PSU]), potential !! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the full range fit coefficients. interface calculate_density_wright_full module procedure calculate_density_scalar_wright, calculate_density_array_wright end interface calculate_density_wright_full @@ -37,7 +25,7 @@ module MOM_EOS_Wright_full !> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect !! to a reference specific volume, from salinity in practical salinity units ([PSU]), potential !! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the full range fit coefficients. interface calculate_spec_vol_wright_full module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright end interface calculate_spec_vol_wright_full @@ -78,10 +66,11 @@ module MOM_EOS_Wright_full contains -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the in situ density of sea water for scalar inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the full range fit coefficients. subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) real, intent(in) :: T !< Potential temperature relative to the surface [degC]. real, intent(in) :: S !< Salinity [PSU]. @@ -89,14 +78,7 @@ subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) real, intent(out) :: rho !< In situ density [kg m-3]. real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * [kg m-3]) from salinity (S [PSU]), potential temperature * -! * (T [degC]), and pressure [Pa]. It uses the expression from * -! * Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * -! * Coded by R. Hallberg, 7/00 * -! *====================================================================* - + ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] @@ -111,10 +93,11 @@ subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_wright -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the full range fit coefficients. subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. real, dimension(:), intent(in) :: S !< salinity [PSU]. @@ -124,7 +107,6 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ integer, intent(in) :: npts !< the number of values to calculate. real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. ! Local variables real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] real :: p0 ! The pressure offset in the Wright EOS [Pa] @@ -155,10 +137,11 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ end subroutine calculate_density_array_wright -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the Wright in situ specific volume of sea water for scalar inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the full range fit coefficients. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) real, intent(in) :: T !< potential temperature relative to the surface [degC]. @@ -179,10 +162,11 @@ subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) specvol = spv0(1) end subroutine calculate_spec_vol_scalar_wright -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> Computes the Wright in situ specific volume of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the full range fit coefficients. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, spv_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the @@ -213,7 +197,7 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, enddo end subroutine calculate_spec_vol_array_wright -!> For a given thermodynamic state, return the thermal/haline expansion coefficients +!> Return the thermal/haline expansion coefficients for 1-d array inputs and outputs subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_dS, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the !! surface [degC]. @@ -250,8 +234,10 @@ subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_d end subroutine calculate_density_derivs_array_wright -!> The scalar version of calculate_density_derivs which promotes scalar inputs to a 1-element array and then -!! demotes the output back to a scalar +!> Return the thermal/haline expansion coefficients for scalar inputs and outputs +!! +!! The scalar version of calculate_density_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_dS) real, intent(in) :: T !< Potential temperature relative to the surface [degC]. real, intent(in) :: S !< Salinity [PSU]. @@ -277,7 +263,7 @@ subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_ end subroutine calculate_density_derivs_scalar_wright -!> Second derivatives of density with respect to temperature, salinity, and pressure +!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp, start, npts) real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] @@ -337,8 +323,10 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh end subroutine calculate_density_second_derivs_array_wright -!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. Inputs -!! promoted to 1-element array and output demoted to scalar +!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. +!! +!! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp) real, intent(in ) :: T !< Potential temperature referenced to 0 dbar @@ -379,8 +367,8 @@ subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, dr end subroutine calculate_density_second_derivs_scalar_wright -!> For a given thermodynamic state, return the partial derivatives of specific volume -!! with temperature and salinity +!> Return the partial derivatives of specific volume with temperature and salinity +!! for 1-d array inputs and outputs subroutine calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. real, intent(in), dimension(:) :: S !< Salinity [PSU]. @@ -414,11 +402,7 @@ subroutine calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, end subroutine calculate_specvol_derivs_wright_full -!> This subroutine computes the in situ density of sea water (rho in [kg m-3]) -!! and the compressibility (drho/dp = C_sound^-2) (drho_dp [s2 m-2]) from -!! salinity (sal [PSU]), potential temperature (T [degC]), and pressure [Pa]. -!! It uses the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! Coded by R. Hallberg, 1/01 +!> Computes the compressibility of seawater for 1-d array inputs and outputs subroutine calculate_compress_wright_full(T, S, pressure, rho, drho_dp, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. real, intent(in), dimension(:) :: S !< Salinity [PSU]. @@ -430,7 +414,6 @@ subroutine calculate_compress_wright_full(T, S, pressure, rho, drho_dp, start, n integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. - ! Coded by R. Hallberg, 1/01 ! Local variables real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] real :: p0 ! The pressure offset in the Wright EOS [Pa] @@ -449,9 +432,11 @@ subroutine calculate_compress_wright_full(T, S, pressure, rho, drho_dp, start, n enddo end subroutine calculate_compress_wright_full -!> This subroutine calculates analytical and nearly-analytical integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) @@ -707,12 +692,11 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & end subroutine int_density_dz_wright_full -!> This subroutine calculates 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 non-Boussinesq -!! model. There are essentially no free assumptions, apart from the use of -!! Boole's rule to do the horizontal integrals, and from a truncation in the -!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +!> Calculates 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 +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) @@ -947,4 +931,24 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_wright_full +!> \namespace mom_eos_wright_full +!! +!! \section section_EOS_Wright Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the full range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + end module MOM_EOS_Wright_full From 4d74bfde68780b1e374316f619292c9291ef727c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 Feb 2023 13:12:36 -0500 Subject: [PATCH 45/91] (*)Rearranged parentheses in MOM_EOS_Wright_full Added parentheses to all expressions with three or more additions or multiplications in the MOM_EOS_Wright_full code, so that different compilers and compiler settings will reproduce the same answers in more cases. In doing this, an effort was made to add the smallest terms first to reduce the impact of roundoff. In some cases, the code was deliberately rearranged to cancel out the leading order terms more completely. In addition, two bugs had been identified in calculate_density_second_derivs_wright_full. These were corrected and the entire routine substantially refactored with renamed variables to make the derivation easier to follow and verify. Apart from the bug corrections in the calculation of drho_dt_dt and drho_dt_dp, the changes in the expressions are mathematically equivalent, but they might make the model less noisy in some cases by reducing contributions from round-off errors. Also added comments highlighting two bugs in the drho_dt_dt and drho_dt_dp calculations in calculate_density_second_derivs_wright in the original MOM_EOS_Wright code, but did not correct them to preserve the previous answers. --- src/equation_of_state/MOM_EOS_Wright.F90 | 3 +- src/equation_of_state/MOM_EOS_Wright_full.F90 | 191 +++++++++--------- 2 files changed, 102 insertions(+), 92 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 36180d14e8..5fd67dcfb3 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -300,7 +300,7 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh do j = start,start+npts-1 z0 = T(j)*(b1 + b5*S(j) + T(j)*(b2 + b3*T(j))) z1 = (b0 + P(j) + b4*S(j) + z0) - z3 = (b1 + b5*S(j) + T(j)*(2.*b2 + 2.*b3*T(j))) + z3 = (b1 + b5*S(j) + T(j)*(2.*b2 + 2.*b3*T(j))) ! BUG: This should be z3 = b1 + b5*S(j) + T(j)*(2.*b2 + 3.*b3*T(j)) z4 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j)))) z5 = (b1 + b5*S(j) + T(j)*(b2 + b3*T(j)) + T(j)*(b2 + 2.*b3*T(j))) z6 = c1 + c5*S(j) + T(j)*(c2 + c3*T(j)) + T(j)*(c2 + 2.*c3*T(j)) @@ -315,6 +315,7 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh drho_ds_ds(j) = (z10*(c4 + c5*T(j)) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T(j) + z9*z10 + a2*z1)*z11)/z2_3 drho_ds_dt(j) = (z10*z6 - z1*(c5 + a2*z5) + b5*z4 - z5*z7)/z2_2 - (2.*(z6 + z9*z5 + a1*z1)*z11)/z2_3 + ! BUG: In the following line: (2.*b2 + 4.*b3*T(j)) should be (2.*b2 + 6.*b3*T(j)) drho_dt_dt(j) = (z3*z6 - z1*(2.*c2 + 6.*c3*T(j) + a1*z5) + (2.*b2 + 4.*b3*T(j))*z4 - z5*z8)/z2_2 - & (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 drho_ds_dp(j) = (-c4 - c5*T(j) - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 72aa38faf3..e79b392cde 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -30,12 +30,12 @@ module MOM_EOS_Wright_full module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright end interface calculate_spec_vol_wright_full -!> For a given thermodynamic state, return the derivatives of density with temperature and salinity +!> Compute the derivatives of density with temperature and salinity interface calculate_density_derivs_wright_full module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright end interface calculate_density_derivs_wright_full -!> For a given thermodynamic state, return the second derivatives of density with various combinations +!> Compute the second derivatives of density with various combinations !! of temperature, salinity, and pressure interface calculate_density_second_derivs_wright_full module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright @@ -117,9 +117,9 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] integer :: j - if (present(rho_ref)) pa_000 = (b0*(1.0 - a0*rho_ref) - rho_ref*c0) + if (present(rho_ref)) pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 if (present(rho_ref)) then ; do j=start,start+npts-1 - al_TS = a1*T(j) +a2*S(j) + al_TS = a1*T(j) + a2*S(j) al0 = a0 + al_TS p_TSp = pressure(j) + (b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j)))) lam_TS = c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) @@ -129,9 +129,9 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ rho(j) = (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) enddo ; else ; do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) +a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*(b2 + b3*T(j)) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*(c2 + c3*T(j)) + c5*S(j)) + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) enddo ; endif @@ -185,9 +185,9 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, integer :: j do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) +a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) if (present(spv_ref)) then specvol(j) = (lambda + (al0 - spv_ref)*(pressure(j) + p0)) / (pressure(j) + p0) @@ -218,18 +218,15 @@ subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_d integer :: j do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) + a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) - - I_denom2 = 1.0 / (lambda + al0*(pressure(j) + p0)) - I_denom2 = I_denom2 *I_denom2 - drho_dT(j) = I_denom2 * & - (lambda* (b1 + T(j)*(2.0*b2 + 3.0*b3*T(j)) + b5*S(j)) - & - (pressure(j)+p0) * ( (pressure(j)+p0)*a1 + & - (c1 + T(j)*(c2*2.0 + c3*3.0*T(j)) + c5*S(j)) )) - drho_dS(j) = I_denom2 * (lambda* (b4 + b5*T(j)) - & - (pressure(j)+p0) * ( (pressure(j)+p0)*a2 + (c4 + c5*T(j)) )) + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure(j) + p0))**2 + drho_dT(j) = I_denom2 * (lambda * (b1 + (T(j)*(2.0*b2 + 3.0*b3*T(j)) + b5*S(j))) - & + (pressure(j)+p0) * ( (pressure(j)+p0)*a1 + (c1 + (T(j)*(c2*2.0 + c3*3.0*T(j)) + c5*S(j))) )) + drho_dS(j) = I_denom2 * (lambda * (b4 + b5*T(j)) - & + (pressure(j)+p0) * ( (pressure(j)+p0)*a2 + (c4 + c5*T(j)) )) enddo end subroutine calculate_density_derivs_array_wright @@ -283,42 +280,55 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh integer, intent(in ) :: npts !< Number of points to loop over ! Local variables - real :: z0, z1 ! Local work variables [Pa] - real :: z2, z4 ! Local work variables [m2 s-2] - real :: z3, z5 ! Local work variables [Pa degC-1] - real :: z6, z8 ! Local work variables [m2 s-2 degC-1] - real :: z7 ! A local work variable [m2 s-2 PSU-1] - real :: z9 ! A local work variable [m3 kg-1] - real :: z10 ! A local work variable [Pa PSU-1] - real :: z11 ! A local work variable [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] - real :: z2_2 ! A local work variable [m4 s-4] - real :: z2_3 ! A local work variable [m6 s-6] + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: p_p0 ! A local work variable combining the pressure and pressure + ! offset (p0 elsewhere) in the Wright EOS [Pa] + real :: dp0_dT ! The partial derivative of p0 with temperature [Pa degC-1] + real :: dp0_dS ! The partial derivative of p0 with salinity [Pa PSU-1] + real :: dlam_dT ! The partial derivative of lambda with temperature [m2 s-2 degC-1] + real :: dlam_dS ! The partial derivative of lambda with salinity [m2 s-2 degC-1] + real :: dRdT_num ! The numerator in the expression for drho_dT [Pa m2 s-2 degC-1] = [kg m s-4 degC-1] + real :: dRdS_num ! The numerator in the expression for drho_ds [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: ddenom_dT ! The derivative of the denominator of density in the Wright EOS with temperature [m2 s-2 deg-1] + real :: ddenom_dS ! The derivative of the denominator of density in the Wright EOS with salinity [m2 s-2 PSU-1] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + real :: I_denom3 ! The inverse of the cube of the denominator of density in the Wright EOS [s6 m-6] integer :: j - ! Based on the above expression with common terms factored, there probably exists a more numerically stable - ! and/or efficient expression do j = start,start+npts-1 - z0 = T(j)*(b1 + b5*S(j) + T(j)*(b2 + b3*T(j))) - z1 = (b0 + P(j) + b4*S(j) + z0) - z3 = (b1 + b5*S(j) + T(j)*(2.*b2 + 2.*b3*T(j))) - z4 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j)))) - z5 = (b1 + b5*S(j) + T(j)*(b2 + b3*T(j)) + T(j)*(b2 + 2.*b3*T(j))) - z6 = c1 + c5*S(j) + T(j)*(c2 + c3*T(j)) + T(j)*(c2 + 2.*c3*T(j)) - z7 = (c4 + c5*T(j) + a2*z1) - z8 = (c1 + c5*S(j) + T(j)*(2.*c2 + 3.*c3*T(j)) + a1*z1) - z9 = (a0 + a2*S(j) + a1*T(j)) - z10 = (b4 + b5*T(j)) - z11 = (z10*z4 - z1*z7) - z2 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j))) + z9*z1) - z2_2 = z2*z2 - z2_3 = z2_2*z2 - - drho_ds_ds(j) = (z10*(c4 + c5*T(j)) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T(j) + z9*z10 + a2*z1)*z11)/z2_3 - drho_ds_dt(j) = (z10*z6 - z1*(c5 + a2*z5) + b5*z4 - z5*z7)/z2_2 - (2.*(z6 + z9*z5 + a1*z1)*z11)/z2_3 - drho_dt_dt(j) = (z3*z6 - z1*(2.*c2 + 6.*c3*T(j) + a1*z5) + (2.*b2 + 4.*b3*T(j))*z4 - z5*z8)/z2_2 - & - (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 - drho_ds_dp(j) = (-c4 - c5*T(j) - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 - drho_dt_dp(j) = (-c1 - c5*S(j) - T(j)*(2.*c2 + 3.*c3*T(j)) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 + al0 = a0 + (a1*T(j) + a2*S(j)) + p_p0 = P(j) + ( b0 + (b4*S(j) + T(j)*(b1 + (b5*S(j) + T(j)*(b2 + b3*T(j))))) ) ! P + p0 + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + dp0_dT = b1 + (b5*S(j) + T(j)*(2.*b2 + 3.*b3*T(j))) + dp0_dS = b4 + b5*T(j) + dlam_dT = c1 + (c5*S(j) + T(j)*(2.*c2 + 3.*c3*T(j))) + dlam_dS = c4 + c5*T(j) + I_denom = 1.0 / (lambda + al0*p_p0) + I_denom2 = I_denom*I_denom + I_denom3 = I_denom*I_denom2 + + ddenom_dS = (dlam_dS + a2*p_p0) + al0*dp0_dS + ddenom_dT = (dlam_dT + a1*p_p0) + al0*dp0_dT + dRdS_num = dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0) + dRdT_num = dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0) + + ! In deriving the following, it is useful to note that: + ! rho(j) = p_p0 / (lambda + al0*p_p0) + ! drho_dp(j) = lambda * I_denom2 + ! drho_dT(j) = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS(j) = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds(j) = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt(j) = ((b5*lambda - p_p0*(c5 + 2.*a2*dp0_dT)) + (dp0_dS*dlam_dT - dp0_dT*dlam_dS))*I_denom2 - & + 2.*(ddenom_dT*dRdS_num) * I_denom3 + drho_dt_dt(j) = 2.*((b2 + 3.*b3*T(j))*lambda - p_p0*((c2 + 3.*c3*T(j)) + a1*dp0_dT))*I_denom2 - & + 2.*(dRdT_num * ddenom_dT) * I_denom3 + + ! The following is a rearranged form that is equivalent to + ! drho_ds_dp(j) = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp(j) = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp(j) = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 enddo end subroutine calculate_density_second_derivs_array_wright @@ -387,17 +397,17 @@ subroutine calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, integer :: j do j=start,start+npts-1 -! al0 = (a0 + a1*T(j)) + a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) +! al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) ! SV = al0 + lambda / (pressure(j) + p0) I_denom = 1.0 / (pressure(j) + p0) - dSV_dT(j) = (a1 + I_denom * (c1 + T(j)*((2.0*c2 + 3.0*c3*T(j))) + c5*S(j))) - & - (I_denom**2 * lambda) * (b1 + T(j)*((2.0*b2 + 3.0*b3*T(j))) + b5*S(j)) - dSV_dS(j) = (a2 + I_denom * (c4 + c5*T(j))) - & - (I_denom**2 * lambda) * (b4 + b5*T(j)) + dSV_dT(j) = a1 + I_denom * ((c1 + (T(j)*(2.0*c2 + 3.0*c3*T(j)) + c5*S(j))) - & + (I_denom * lambda) * (b1 + (T(j)*(2.0*b2 + 3.0*b3*T(j)) + b5*S(j)))) + dSV_dS(j) = a2 + I_denom * ((c4 + c5*T(j)) - & + (I_denom * lambda) * (b4 + b5*T(j))) enddo end subroutine calculate_specvol_derivs_wright_full @@ -422,13 +432,13 @@ subroutine calculate_compress_wright_full(T, S, pressure, rho, drho_dp, start, n integer :: j do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) +a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) I_denom = 1.0 / (lambda + al0*(pressure(j) + p0)) rho(j) = (pressure(j) + p0) * I_denom - drho_dp(j) = lambda * I_denom * I_denom + drho_dp(j) = lambda * I_denom**2 enddo end subroutine calculate_compress_wright_full @@ -585,9 +595,9 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & endif ; endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j) - p0_2d(i,j) = (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) - lambda_2d(i,j) = (c0 +c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) + al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) + p0_2d(i,j) = b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) + lambda_2d(i,j) = c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) @@ -595,17 +605,16 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) I_al0 = 1.0 / al0 - I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) - eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps ! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks - rem = I_Rho * (lambda * I_al0**2) * eps2 * & - (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) - dpa(i,j) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem) + rem = (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) + dpa(i,j) = Pa_to_RL2_T2 * ((g_Earth*rho_anom)*dz - 2.0*eps*rem) if (present(intz_dpa)) & - intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*g_Earth*rho_anom*dz**2 - dz*(1.0+eps)*rem) + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*(g_Earth*rho_anom)*dz**2 - dz*((1.0+eps)*rem)) enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq @@ -639,11 +648,11 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres) I_al0 = 1.0 / al0 - I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) - eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps - intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & - I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) enddo ! Use Boole's rule to integrate the values. intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) @@ -680,11 +689,11 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres) I_al0 = 1.0 / al0 - I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) - eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps - intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & - I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) enddo ! Use Boole's rule to integrate the values. inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) @@ -832,20 +841,20 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh - al0_2d(i,j) = al0_scale * ( (a0 + a1s*T(i,j)) + a2s*S(i,j) ) - p0_2d(i,j) = p0_scale * ( (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) ) - lambda_2d(i,j) = lam_scale * ( (c0 + c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) ) + al0_2d(i,j) = al0_scale * ( a0 + (a1s*T(i,j) + a2s*S(i,j)) ) + p0_2d(i,j) = p0_scale * ( b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) ) + lambda_2d(i,j) = lam_scale * ( c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) ) al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dp = p_b(i,j) - p_t(i,j) p_ave = 0.5*(p_t(i,j)+p_b(i,j)) eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - alpha_anom = al0 + lambda / (p0 + p_ave) - spv_ref - rem = lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + alpha_anom = (al0 - spv_ref) + lambda / (p0 + p_ave) + rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) dza(i,j) = alpha_anom*dp + 2.0*eps*rem if (present(intp_dza)) & - intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*(1.0-eps)*rem + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*((1.0-eps)*rem) enddo ; enddo if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq @@ -881,7 +890,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & + intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Boole's rule to integrate the values. @@ -922,7 +931,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & + intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Boole's rule to integrate the values. From f650db6e6aad83f925f29ab129618c5315b34e20 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Feb 2023 08:13:28 -0500 Subject: [PATCH 46/91] +Created the new module MOM_EOS_Wright_red Created a new module, MOM_EOS_Wright_red, that uses the reduced range fit coefficients from the Wright EOS paper, but uses the parentheses, expressions and bug fixes that are now in MOM_EOS_Wright_full. To use this new module, set EQN_OF_STATE="WRIGHT_RED". This new form is mathematically equivalent using EQN_OF_STATE="WRIGHT" (apart from correcting the bugs in the calculations of drho_dt_dt and drho_dt_dp), but the order of arithmetic is different, so the answers will differ. This change is probably as close as we can come to addressing the issues discussed at github.com/mom-ocean/MOM6/issues/1331, so that issue should be closed once this commit is merged onto the main branch. Also corrected some misleading error messages in MOM_EOS and modified the code to properly handle the case for equations of state (like NEMO and UNESCO) that do not have a scalar form of calculate_density_derivs, but do have an array form. By default, all answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 137 ++- src/equation_of_state/MOM_EOS_Wright_red.F90 | 963 +++++++++++++++++++ 2 files changed, 1081 insertions(+), 19 deletions(-) create mode 100644 src/equation_of_state/MOM_EOS_Wright_red.F90 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index a49cc39058..6c8900172f 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -18,6 +18,11 @@ module MOM_EOS use MOM_EOS_Wright_full, only : calculate_specvol_derivs_wright_full, int_density_dz_wright_full use MOM_EOS_Wright_full, only : calculate_compress_wright_full, int_spec_vol_dp_wright_full use MOM_EOS_Wright_full, only : calculate_density_second_derivs_wright_full +use MOM_EOS_Wright_red, only : calculate_density_wright_red, calculate_spec_vol_wright_red +use MOM_EOS_Wright_red, only : calculate_density_derivs_wright_red +use MOM_EOS_Wright_red, only : calculate_specvol_derivs_wright_red, int_density_dz_wright_red +use MOM_EOS_Wright_red, only : calculate_compress_wright_red, int_spec_vol_dp_wright_red +use MOM_EOS_Wright_red, only : calculate_density_second_derivs_wright_red use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco use MOM_EOS_UNESCO, only : calculate_compress_unesco @@ -131,7 +136,7 @@ module MOM_EOS real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1] ! Unit conversion factors (normally used for dimensional testing but could also allow for -! change of units of arguments to functions +! change of units of arguments to functions) real :: m_to_Z = 1. !< A constant that translates distances in meters to the units of depth [Z m-1 ~> 1] real :: kg_m3_to_R = 1. !< A constant that translates kilograms per meter cubed to the !! units of density [R m3 kg-1 ~> 1] @@ -152,8 +157,9 @@ module MOM_EOS integer, parameter, public :: EOS_UNESCO = 2 !< A named integer specifying an equation of state integer, parameter, public :: EOS_WRIGHT = 3 !< A named integer specifying an equation of state integer, parameter, public :: EOS_WRIGHT_FULL = 4 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_TEOS10 = 5 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_NEMO = 6 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT_RED = 5 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_TEOS10 = 6 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_NEMO = 7 !< A named integer specifying an equation of state character*(10), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state character*(10), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state @@ -252,6 +258,15 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) + case (EOS_WRIGHT_RED) + call calculate_density_second_derivs_wright_red(T_scale*T, S_scale*S, p_scale*pressure, & + d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) + case (EOS_UNESCO) + call MOM_error(FATAL, "calculate_stanley_density_scalar: "//& + "EOS_UNESCO is not set up to calculate second derivatives yet.") + case (EOS_NEMO) + call MOM_error(FATAL, "calculate_stanley_density_scalar: "//& + "EOS_NEMO is not set up to calculate second derivatives yet.") case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) @@ -293,6 +308,8 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) case (EOS_WRIGHT_FULL) call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_WRIGHT_RED) + call calculate_density_wright_red(T, S, pressure, rho, start, npts, rho_ref) case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) case (EOS_NEMO) @@ -349,6 +366,17 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_wright_full(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_WRIGHT_RED) + call calculate_density_wright_red(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_wright_red(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_UNESCO) + call MOM_error(FATAL, "calculate_stanley_density_array: "//& + "EOS_UNESCO is not set up to calculate second derivatives yet.") + case (EOS_NEMO) + call calculate_density_NEMO(T, S, pressure, rho, start, npts, rho_ref) + call MOM_error(FATAL, "calculate_stanley_density_array: "//& + "EOS_NEMO is not set up to calculate second derivatives yet.") case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & @@ -492,12 +520,23 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, call calculate_density_wright_full(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) + case (EOS_WRIGHT_RED) + call calculate_density_wright_red(Ta, Sa, pres, rho, is, npts, rho_reference) + call calculate_density_second_derivs_wright_red(Ta, Sa, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, is, npts) + case (EOS_UNESCO) + call MOM_error(FATAL, "calculate_stanley_density_1d: "//& + "EOS_UNESCO is not set up to calculate second derivatives yet.") + case (EOS_NEMO) + call calculate_density_NEMO(Ta, Sa, pres, rho, is, npts, rho_reference) + call MOM_error(FATAL, "calculate_stanley_density_1d: "//& + "EOS_NEMO is not set up to calculate second derivatives yet.") case (EOS_TEOS10) call calculate_density_teos10(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_teos10(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) case default - call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + call MOM_error(FATAL, "calculate_stanley_density_1d: EOS is not valid.") end select ! Equation 25 of Stanley et al., 2020. @@ -542,6 +581,8 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s call calculate_spec_vol_wright(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_WRIGHT_FULL) call calculate_spec_vol_wright_full(T, S, pressure, specvol, start, npts, spv_ref) + case (EOS_WRIGHT_RED) + call calculate_spec_vol_wright_red(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_TEOS10) call calculate_spec_vol_teos10(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_NEMO) @@ -831,6 +872,8 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_WRIGHT_FULL) call calculate_density_derivs_wright_full(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_WRIGHT_RED) + call calculate_density_derivs_wright_red(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_TEOS10) call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_NEMO) @@ -918,26 +961,32 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] - real :: pres ! Pressure converted to [Pa] - real :: Ta ! Temperature converted to [degC] - real :: Sa ! Salinity converted to [ppt] + real :: pres(1) ! Pressure converted to [Pa] + real :: Ta(1) ! Temperature converted to [degC] + real :: Sa(1) ! Salinity converted to [ppt] + real :: dR_dT(1) ! A copy of drho_dT in mks units [kg m-3 degC-1] + real :: dR_dS(1) ! A copy of drho_dS in mks units [kg m-3 ppt-1] - pres = EOS%RL2_T2_to_Pa*pressure - Ta = EOS%C_to_degC * T - Sa = EOS%S_to_ppt * S + pres(1) = EOS%RL2_T2_to_Pa*pressure + Ta(1) = EOS%C_to_degC * T + Sa(1) = EOS%S_to_ppt * S select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_derivs_linear(Ta, Sa, pres, drho_dT, drho_dS, & + call calculate_density_derivs_linear(Ta(1), Sa(1), pres(1),drho_dT, drho_dS, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_WRIGHT) - call calculate_density_derivs_wright(Ta, Sa, pres, drho_dT, drho_dS) + call calculate_density_derivs_wright(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) case (EOS_WRIGHT_FULL) - call calculate_density_derivs_wright_full(Ta, Sa, pres, drho_dT, drho_dS) + call calculate_density_derivs_wright_full(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) + case (EOS_WRIGHT_RED) + call calculate_density_derivs_wright_red(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) case (EOS_TEOS10) - call calculate_density_derivs_teos10(Ta, Sa, pres, drho_dT, drho_dS) + call calculate_density_derivs_teos10(Ta(1), Sa(1), pres(1), drho_dT, drho_dS) case default - call MOM_error(FATAL, "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") + ! Some equations of state do not have a scalar form of calculate_density_derivs, so try the array form. + call calculate_density_derivs_array(Ta, Sa, pres, dR_dT, dR_dS, 1, 1, EOS) + drho_dT = dR_dT(1); drho_dS = dR_dS(1) end select rho_scale = EOS%kg_m3_to_R @@ -996,11 +1045,20 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_WRIGHT_RED) + call calculate_density_second_derivs_wright_red(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_UNESCO) + call MOM_error(FATAL, "calculate_density_second_derivs: "//& + "EOS_UNESCO is not set up to calculate second derivatives yet.") + case (EOS_NEMO) + call MOM_error(FATAL, "calculate_density_second_derivs: "//& + "EOS_NEMO is not set up to calculate second derivatives yet.") case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case default - call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") end select else do i=is,ie @@ -1018,11 +1076,20 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_WRIGHT_RED) + call calculate_density_second_derivs_wright_red(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_UNESCO) + call MOM_error(FATAL, "calculate_density_second_derivs: "//& + "EOS_UNESCO is not set up to calculate second derivatives yet.") + case (EOS_NEMO) + call MOM_error(FATAL, "calculate_density_second_derivs: "//& + "EOS_NEMO is not set up to calculate second derivatives yet.") case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case default - call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") end select endif @@ -1094,11 +1161,20 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) + case (EOS_WRIGHT_RED) + call calculate_density_second_derivs_wright_red(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) + case (EOS_UNESCO) + call MOM_error(FATAL, "calculate_density_second_derivs: "//& + "EOS_UNESCO is not set up to calculate second derivatives yet.") + case (EOS_NEMO) + call MOM_error(FATAL, "calculate_density_second_derivs: "//& + "EOS_NEMO is not set up to calculate second derivatives yet.") case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case default - call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") end select rho_scale = EOS%kg_m3_to_R @@ -1164,6 +1240,8 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_WRIGHT_FULL) call calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_WRIGHT_RED) + call calculate_specvol_derivs_wright_red(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_TEOS10) call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_NEMO) @@ -1275,6 +1353,8 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) call calculate_compress_wright(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_WRIGHT_FULL) call calculate_compress_wright_full(Ta, Sa, pres, rho, drho_dp, is, npts) + case (EOS_WRIGHT_RED) + call calculate_compress_wright_red(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_TEOS10) call calculate_compress_teos10(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_NEMO) @@ -1413,6 +1493,11 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) + case (EOS_WRIGHT_RED) + call int_spec_vol_dp_wright_red(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") end select @@ -1515,6 +1600,19 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & dz_neglect, useMassWghtInterp, Z_0p=Z_0p) endif + case (EOS_WRIGHT_RED) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then + call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) + else + call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & + dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + endif case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") end select @@ -1558,7 +1656,7 @@ subroutine EOS_init(param_file, EOS, US) case (EOS_WRIGHT_STRING) EOS%form_of_EOS = EOS_WRIGHT case (EOS_WRIGHT_RED_STRING) - EOS%form_of_EOS = EOS_WRIGHT + EOS%form_of_EOS = EOS_WRIGHT_RED case (EOS_WRIGHT_FULL_STRING) EOS%form_of_EOS = EOS_WRIGHT_FULL case (EOS_TEOS10_STRING) @@ -1590,6 +1688,7 @@ subroutine EOS_init(param_file, EOS, US) EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & (EOS%form_of_EOS == EOS_WRIGHT) .or. & + (EOS%form_of_EOS == EOS_WRIGHT_RED) .or. & (EOS%form_of_EOS == EOS_WRIGHT_FULL)) call get_param(param_file, mdl, "EOS_QUADRATURE", EOS%EOS_quadrature, & "If true, always use the generic (quadrature) code "//& diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 new file mode 100644 index 0000000000..4a867468b9 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -0,0 +1,963 @@ +!> The equation of state using the Wright 1997 expressions +module MOM_EOS_Wright_red + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +#include + +public calculate_compress_wright_red, calculate_density_wright_red, calculate_spec_vol_wright_red +public calculate_density_derivs_wright_red, calculate_specvol_derivs_wright_red +public calculate_density_second_derivs_wright_red +public int_density_dz_wright_red, int_spec_vol_dp_wright_red + +!> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to +!! a reference density, from salinity in practical salinity units ([PSU]), potential +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. +interface calculate_density_wright_red + module procedure calculate_density_scalar_wright, calculate_density_array_wright +end interface calculate_density_wright_red + +!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect +!! to a reference specific volume, from salinity in practical salinity units ([PSU]), potential +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. +interface calculate_spec_vol_wright_red + module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright +end interface calculate_spec_vol_wright_red + +!> Compute the derivatives of density with temperature and salinity +interface calculate_density_derivs_wright_red + module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright +end interface calculate_density_derivs_wright_red + +!> Compute the second derivatives of density with various combinations +!! of temperature, salinity, and pressure +interface calculate_density_second_derivs_wright_red + module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright +end interface calculate_density_second_derivs_wright_red + +!>@{ Parameters in the Wright equation of state using the reduced range formula, which is a fit to the UNESCO +! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. + + ! Note that a0/a1 ~= 2028 [degC] ; a0/a2 ~= -6343 [PSU] + ! b0/b1 ~= 165 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -740 [PSU] +real, parameter :: a0 = 7.057924e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 3.480336e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.112733e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.790749e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.516535e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -4.002714e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 2.084372e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 5.944068e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -9.643486e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.704853e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 7.904722e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -7.984422 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 5.140652e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -2.302158e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -3.079464 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] +!>@} + +contains + +!> Computes the in situ density of sea water for scalar inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. +subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: rho0 ! A 1-d array with a copy of the density [kg m-3] + + T0(1) = T + S0(1) = S + pressure0(1) = pressure + + call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1, rho_ref) + rho = rho0(1) + +end subroutine calculate_density_scalar_wright + +!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. +subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(inout) :: rho !< in situ density [kg m-3]. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + integer :: j + + if (present(rho_ref)) pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 + if (present(rho_ref)) then ; do j=start,start+npts-1 + al_TS = a1*T(j) + a2*S(j) + al0 = a0 + al_TS + p_TSp = pressure(j) + (b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j)))) + lam_TS = c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) + + ! The following two expressions are mathematically equivalent. + ! rho(j) = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + rho(j) = (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + enddo ; else ; do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + enddo ; endif + +end subroutine calculate_density_array_wright + +!> Computes the Wright in situ specific volume of sea water for scalar inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: spv0 ! A 1-d array with a copy of the specific volume [m3 kg-1] + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + + call calculate_spec_vol_array_wright(T0, S0, pressure0, spv0, 1, 1, spv_ref) + specvol = spv0(1) +end subroutine calculate_spec_vol_scalar_wright + +!> Computes the Wright in situ specific volume of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the + !! surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [m3 kg-1]. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + integer :: j + + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + if (present(spv_ref)) then + specvol(j) = (lambda + (al0 - spv_ref)*(pressure(j) + p0)) / (pressure(j) + p0) + else + specvol(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + endif + enddo +end subroutine calculate_spec_vol_array_wright + +!> Return the thermal/haline expansion coefficients for 1-d array inputs and outputs +subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_dS, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the + !! surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(inout), dimension(:) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + integer :: j + + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure(j) + p0))**2 + drho_dT(j) = I_denom2 * (lambda * (b1 + (T(j)*(2.0*b2 + 3.0*b3*T(j)) + b5*S(j))) - & + (pressure(j)+p0) * ( (pressure(j)+p0)*a1 + (c1 + (T(j)*(c2*2.0 + c3*3.0*T(j)) + c5*S(j))) )) + drho_dS(j) = I_denom2 * (lambda * (b4 + b5*T(j)) - & + (pressure(j)+p0) * ( (pressure(j)+p0)*a2 + (c4 + c5*T(j)) )) + enddo + +end subroutine calculate_density_derivs_array_wright + +!> Return the thermal/haline expansion coefficients for scalar inputs and outputs +!! +!! The scalar version of calculate_density_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar +subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_dS) + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1]. + + ! Local variables needed to promote the input/output scalars to 1-element arrays + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdt0 ! The derivative of density with temperature [kg m-3 degC-1] + real, dimension(1) :: drds0 ! The derivative of density with salinity [kg m-3 PSU-1] + + T0(1) = T + S0(1) = S + P0(1) = pressure + call calculate_density_derivs_array_wright(T0, S0, P0, drdt0, drds0, 1, 1) + drho_dT = drdt0(1) + drho_dS = drds0(1) + +end subroutine calculate_density_derivs_scalar_wright + +!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. +subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] + real, dimension(:), intent(in ) :: S !< Salinity [PSU] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: p_p0 ! A local work variable combining the pressure and pressure + ! offset (p0 elsewhere) in the Wright EOS [Pa] + real :: dp0_dT ! The partial derivative of p0 with temperature [Pa degC-1] + real :: dp0_dS ! The partial derivative of p0 with salinity [Pa PSU-1] + real :: dlam_dT ! The partial derivative of lambda with temperature [m2 s-2 degC-1] + real :: dlam_dS ! The partial derivative of lambda with salinity [m2 s-2 degC-1] + real :: dRdT_num ! The numerator in the expression for drho_dT [Pa m2 s-2 degC-1] = [kg m s-4 degC-1] + real :: dRdS_num ! The numerator in the expression for drho_ds [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: ddenom_dT ! The derivative of the denominator of density in the Wright EOS with temperature [m2 s-2 deg-1] + real :: ddenom_dS ! The derivative of the denominator of density in the Wright EOS with salinity [m2 s-2 PSU-1] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + real :: I_denom3 ! The inverse of the cube of the denominator of density in the Wright EOS [s6 m-6] + integer :: j + + do j = start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p_p0 = P(j) + ( b0 + (b4*S(j) + T(j)*(b1 + (b5*S(j) + T(j)*(b2 + b3*T(j))))) ) ! P + p0 + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + dp0_dT = b1 + (b5*S(j) + T(j)*(2.*b2 + 3.*b3*T(j))) + dp0_dS = b4 + b5*T(j) + dlam_dT = c1 + (c5*S(j) + T(j)*(2.*c2 + 3.*c3*T(j))) + dlam_dS = c4 + c5*T(j) + I_denom = 1.0 / (lambda + al0*p_p0) + I_denom2 = I_denom*I_denom + I_denom3 = I_denom*I_denom2 + + ddenom_dS = (dlam_dS + a2*p_p0) + al0*dp0_dS + ddenom_dT = (dlam_dT + a1*p_p0) + al0*dp0_dT + dRdS_num = dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0) + dRdT_num = dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0) + + ! In deriving the following, it is useful to note that: + ! rho(j) = p_p0 / (lambda + al0*p_p0) + ! drho_dp(j) = lambda * I_denom2 + ! drho_dT(j) = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS(j) = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds(j) = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt(j) = ((b5*lambda - p_p0*(c5 + 2.*a2*dp0_dT)) + (dp0_dS*dlam_dT - dp0_dT*dlam_dS))*I_denom2 - & + 2.*(ddenom_dT*dRdS_num) * I_denom3 + drho_dt_dt(j) = 2.*((b2 + 3.*b3*T(j))*lambda - p_p0*((c2 + 3.*c3*T(j)) + a1*dp0_dT))*I_denom2 - & + 2.*(dRdT_num * ddenom_dT) * I_denom3 + + ! The following is a rearranged form that is equivalent to + ! drho_ds_dp(j) = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp(j) = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp(j) = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 + enddo + +end subroutine calculate_density_second_derivs_array_wright + +!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. +!! +!! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar +subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Potential temperature referenced to 0 dbar + real, intent(in ) :: S !< Salinity [PSU] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 PSU-2] + real, dimension(1) :: drdsdt ! The second derivative of density with salinity and + ! temperature [kg m-3 PSU-1 degC-1] + real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] + real, dimension(1) :: drdsdp ! The second derivative of density with salinity and + ! pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(1) :: drdtdp ! The second derivative of density with temperature and + ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + T0(1) = T + S0(1) = S + P0(1) = P + call calculate_density_second_derivs_array_wright(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + drho_ds_ds = drdsds(1) + drho_ds_dt = drdsdt(1) + drho_dt_dt = drdtdt(1) + drho_ds_dp = drdsdp(1) + drho_dt_dp = drdtdp(1) + +end subroutine calculate_density_second_derivs_scalar_wright + +!> Return the partial derivatives of specific volume with temperature and salinity +!! for 1-d array inputs and outputs +subroutine calculate_specvol_derivs_wright_red(T, S, pressure, dSV_dT, dSV_dS, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1]. + real, intent(inout), dimension(:) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + integer :: j + + do j=start,start+npts-1 +! al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + ! SV = al0 + lambda / (pressure(j) + p0) + + I_denom = 1.0 / (pressure(j) + p0) + dSV_dT(j) = a1 + I_denom * ((c1 + (T(j)*(2.0*c2 + 3.0*c3*T(j)) + c5*S(j))) - & + (I_denom * lambda) * (b1 + (T(j)*(2.0*b2 + 3.0*b3*T(j)) + b5*S(j)))) + dSV_dS(j) = a2 + I_denom * ((c4 + c5*T(j)) - & + (I_denom * lambda) * (b4 + b5*T(j))) + enddo + +end subroutine calculate_specvol_derivs_wright_red + +!> Computes the compressibility of seawater for 1-d array inputs and outputs +subroutine calculate_compress_wright_red(T, S, pressure, rho, drho_dp, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: rho !< In situ density [kg m-3]. + real, intent(inout), dimension(:) :: 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 !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + integer :: j + + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_denom = 1.0 / (lambda + al0*(pressure(j) + p0)) + rho(j) = (pressure(j) + p0) * I_denom + drho_dp(j) = lambda * I_denom**2 + enddo +end subroutine calculate_compress_wright_red + +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, & + useMassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] + real :: p_ave ! The layer averaged pressure [Pa] + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif + z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) + p0_2d(i,j) = b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) + lambda_2d(i,j) = c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + + dz = z_t(i,j) - z_b(i,j) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + +! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks + rem = (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) + dpa(i,j) = Pa_to_RL2_T2 * ((g_Earth*rho_anom)*dz - 2.0*eps*rem) + if (present(intz_dpa)) & + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*(g_Earth*rho_anom)*dz**2 - dz*((1.0+eps)*rem)) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + +end subroutine int_density_dz_wright_red + +!> Calculates 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 +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, dP_neglect, & + useMassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! spv_ref, but this reduces the effects of roundoff. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate + !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = al0_scale * ( a0 + (a1s*T(i,j) + a2s*S(i,j)) ) + p0_2d(i,j) = p0_scale * ( b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) ) + lambda_2d(i,j) = lam_scale * ( c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + alpha_anom = (al0 - spv_ref) + lambda / (p0 + p_ave) + rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*((1.0-eps)*rem) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) + p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) + lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1) + + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_wright_red + +!> \namespace mom_eos_wright_red +!! +!! \section section_EOS_Wright Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the reduced range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright_red From 5dffa7da03751ab1b1e0522f6533043fcf763ceb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Feb 2023 08:04:58 -0500 Subject: [PATCH 47/91] *Fix bug in calculate_spec_vol_linear with spv_ref Corrected a sign error in calculate_spec_vol_array_linear and calculate_spec_vol_scalar_linear when a reference specific volume is provided. This bug will cause any configurations with EQN_OF_STATE="LINEAR" and BOUSSINESQ=False (neither of which is the default value) to have the wrong sign of the pressure gradients and other serious problems, like implausible sea surface and internal interface heights. This combination of parameters would never be used in a realistic ocean model. There are no impacted cases in any of the MOM6-examples tests cases, nor those used in the ESMG or dev/NCAR test suites, and it is very unlikely that any such case would work at all. This bug was present in the original version of the calculate_spec_vol_linear routines, but it was only discovered after the implementation of the comprehensive equation of state unit testing. This will change answers in configurations that could not have worked as viable ocean models, but answers are not impacted in any known configuration, and all solutions in test cases are bitwise identical. --- src/equation_of_state/MOM_EOS_linear.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index dd45e6cd81..dc3a5f59b2 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -119,7 +119,7 @@ subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. if (present(spv_ref)) then - specvol = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T + dRho_dS*S)) / & + specvol = ((1.0 - Rho_T0_S0*spv_ref) - spv_ref*(dRho_dT*T + dRho_dS*S)) / & ( Rho_T0_S0 + (dRho_dT*T + dRho_dS*S)) else specvol = 1.0 / ( Rho_T0_S0 + (dRho_dT*T + dRho_dS*S)) @@ -148,7 +148,7 @@ subroutine calculate_spec_vol_array_linear(T, S, pressure, specvol, start, npts, integer :: j if (present(spv_ref)) then ; do j=start,start+npts-1 - specvol(j) = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T(j) + dRho_dS*S(j))) / & + specvol(j) = ((1.0 - Rho_T0_S0*spv_ref) - spv_ref*(dRho_dT*T(j) + dRho_dS*S(j))) / & ( Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) enddo ; else ; do j=start,start+npts-1 specvol(j) = 1.0 / ( Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) From 71e0bb7e673e4b93ea3ff727491c58505b7dc7bd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Feb 2023 16:47:31 -0500 Subject: [PATCH 48/91] +Add EOS_unit_tests Added the new publicly visible function EOS_unit_tests, along with a call to it from inside of unit_tests. These tests evaluate check values for density and assess the consistency of expressions for variables that can be derived from density with finite-difference estimates of the same variables. These tests reveal inconsistencies or omissions with several of the options for the equation of state. The EOS self-consistency tests that are failing are commented out for now, so that this redacted unit test passes. All answers are bitwise identical, but there can be new diagnostic messages written out. --- src/core/MOM_unit_tests.F90 | 3 + src/equation_of_state/MOM_EOS.F90 | 347 +++++++++++++++++++++++++++++- 2 files changed, 347 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 10782e8890..6e5f8f465f 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -11,6 +11,7 @@ module MOM_unit_tests use MOM_random, only : random_unit_tests use MOM_lateral_boundary_diffusion, only : near_boundary_unit_tests use MOM_CFC_cap, only : CFC_cap_unit_tests +use MOM_EOS, only : EOS_unit_tests implicit none ; private public unit_tests @@ -30,6 +31,8 @@ subroutine unit_tests(verbosity) if (is_root_pe()) then ! The following need only be tested on 1 PE if (string_functions_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: string_functions_unit_tests FAILED") + if (EOS_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: EOS_unit_tests FAILED") if (remapping_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: remapping_unit_tests FAILED") if (neutral_diffusion_unit_tests(verbose)) call MOM_error(FATAL, & diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 6c8900172f..345641e5d0 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -40,6 +40,7 @@ module MOM_EOS use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type +use MOM_io, only : stdout use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type @@ -52,6 +53,7 @@ module MOM_EOS public EOS_manual_init public EOS_quadrature public EOS_use_linear +public EOS_unit_tests public analytic_int_density_dz public analytic_int_specific_vol_dp public calculate_compress @@ -1938,12 +1940,12 @@ end function EOS_quadrature !> Extractor routine for the EOS type if the members need to be accessed outside this module subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) - type(EOS_type), intent(in) :: EOS !< Equation of state structure + type(EOS_type), intent(in) :: EOS !< Equation of state structure integer, optional, intent(out) :: form_of_EOS !< A coded integer indicating the equation of state to use. integer, optional, intent(out) :: form_of_TFreeze !< A coded integer indicating the expression for - !! the potential temperature of the freezing point. + !! the potential temperature of the freezing point. logical, optional, intent(out) :: EOS_quadrature !< If true, always use the generic (quadrature) - !! code for the integrals of density. + !! code for the integrals of density. logical, optional, intent(out) :: Compressible !< If true, in situ density is a function of pressure. real , optional, intent(out) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] real , optional, intent(out) :: drho_dT !< Partial derivative of density with temperature @@ -1969,6 +1971,345 @@ subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, end subroutine extract_member_EOS +!> Runs unit tests for consistency on the equations of state. +!! This should only be called from a single/root thread. +!! It returns True if any test fails, otherwise it returns False. +logical function EOS_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(EOS_type) :: EOS_tmp + logical :: fail + + if (verbose) write(stdout,*) '==== MOM_EOS: EOS_unit_tests ====' + EOS_unit_tests = .false. ! Normally return false + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_UNESCO) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "UNESCO", skip_2nd=.true., & + rho_check=1027.5434579611974*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "UNESCO EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_FULL) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_FULL", & + rho_check=1027.5517744761617*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_FULL EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_RED) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_RED", & + rho_check=1027.5430359634624*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_RED EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT) + ! There are known bugs in two of the second derivatives calculated with the WRIGHT EOS. + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", skip_2nd=.true., & + rho_check=1027.5430359634624*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + ! The NEMO equation of state is not passing some self consistency tests yet. + ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_NEMO) + ! fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "NEMO", & + ! rho_check=1027.4238566366823*EOS_tmp%kg_m3_to_R) + ! if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") + ! EOS_unit_tests = EOS_unit_tests .or. fail + + ! The TEOS10 equation of state is not passing some self consistency tests yet. + ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) + ! fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", & + ! rho_check=1027.4235596149185*EOS_tmp%kg_m3_to_R) + ! if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 EOS has failed some self-consistency tests.") + ! EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", & + rho_check=1023.0*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "LINEAR EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + if (verbose .and. .not.EOS_unit_tests) call MOM_mesg("All EOS consistency tests have passed.") + +end function EOS_unit_tests + +!> Test an equation of state for self-consistency and consistency with check values, returning false +!! if it is consistent by all tests, and true if it fails any test. +logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & + EOS_name, rho_check, spv_check, skip_2nd) result(inconsistent) + real, intent(in) :: T_test !< Potential temperature or conservative temperature [C ~> degC] + real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] + real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), & + optional, intent(in) :: EOS_name !< A name used in error messages to describe the EoS + real, optional, intent(in) :: rho_check !< A check value for the density [R ~> kg m-3] + real, optional, intent(in) :: spv_check !< A check value for the specific volume [R-1 ~> m3 kg-1] + logical, optional, intent(in) :: skip_2nd !< If present and true, do not check the 2nd derivatives. + + ! Local variables + real, dimension(-3:3,-3:3,-3:3) :: T ! Temperatures at the test value and perturbed points [C ~> degC] + real, dimension(-3:3,-3:3,-3:3) :: S ! Salinites at the test value and perturbed points [S ~> ppt] + real, dimension(-3:3,-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] + real, dimension(-3:3,-3:3,-3:3,2) :: rho ! Densities at the test value and perturbed points [R ~> kg m-3] + real, dimension(-3:3,-3:3,-3:3,2) :: spv ! Specific volumes at the test value and perturbed points [R-1 ~> m3 kg-1] + real :: dT ! Magnitude of temperature perturbations [C ~> degC] + real :: dS ! Magnitude of salinity perturbations [S ~> ppt] + real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa] + real :: rho_ref ! A reference density that is extracted for greater accuracy [R ~> kg m-3] + real :: spv_ref ! A reference specific vlume that is extracted for greater accuracy [R-1 ~> m3 kg-1] + real :: drho_dT ! The partial derivative of density with potential + ! temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS ! The partial derivative of density with salinity + ! in [R S-1 ~> kg m-3 ppt-1] + real :: drho_dp ! The partial derivative of density with pressure (also the + ! inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] + real :: dSV_dT(1) ! The partial derivative of specific volume with potential + ! temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: dSV_dS(1) ! The partial derivative of specific volume with salinity + ! [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: drho_dS_dS ! Second derivative of density with respect to S [R S-2 ~> kg m-3 ppt-2] + real :: drho_dS_dT ! Second derivative of density with respect to T and S [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real :: drho_dT_dT ! Second derivative of density with respect to T [R C-2 ~> kg m-3 degC-2] + real :: drho_dS_dP ! Second derivative of density with respect to salinity and pressure + ! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: drho_dT_dP ! Second derivative of density with respect to temperature and pressure + ! [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + + real :: drho_dT_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with potential temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with salinity [R S-1 ~> kg m-3 ppt-1] + real :: drho_dp_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with pressure (also the inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] + real :: dSV_dT_fd(2) ! Two 6th order finite difference estimates of the partial derivative of + ! specific volume with potential temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: dSV_dS_fd(2) ! Two 6th order finite difference estimates of the partial derivative of + ! specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: drho_dS_dS_fd(2) ! Two 6th order finite difference estimates of the second derivative of + ! density with respect to salinity [R S-2 ~> kg m-3 ppt-2] + real :: drho_dS_dT_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to temperature and salinity [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real :: drho_dT_dT_fd(2) ! Two 6th order finite difference estimates of the second derivative of + ! density with respect to temperature [R C-2 ~> kg m-3 degC-2] + real :: drho_dS_dP_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: drho_dT_dP_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + real :: rho_tmp ! A temporary copy of the situ density [R ~> kg m-3] + real :: tol ! The nondimensional tolerance from roundoff [nondim] + real :: r_tol ! Roundoff error on a typical value of density anomaly [R ~> kg m-3] + real :: sv_tol ! Roundoff error on a typical value of specific volume anomaly [R-1 ~> m3 kg-1] + real :: tol_here ! The tolerance for each check, in various units [various] + real :: count_fac ! A factor in the roundoff estimates based on the factors in the numerator and + ! denominator in the finite difference derivative expression [nondim] + real :: count_fac2 ! A factor in the roundoff estimates based on the factors in the numerator and + ! denominator in the finite difference second derivative expression [nondim] + character(len=200) :: mesg + logical :: OK ! True if all checks so far are consistent. + logical :: test_2nd ! If true, do tests on the 2nd derivative calculations + integer :: order ! The order of accuracy of the centered finite difference estimates (2, 4 or 6). + integer :: i, j, k, n + + test_2nd = .true. ; if (present(skip_2nd)) test_2nd = .not.skip_2nd + + dT = 0.1*EOS%degC_to_C ! Temperature perturbations [C ~> degC] + dS = 0.5*EOS%ppt_to_S ! Salinity perturbations [S ~> ppt] + dp = 10.0e4 / EOS%RL2_T2_to_Pa ! Pressure perturbations [R L2 T-2 ~> Pa] + + r_tol = 50.0*EOS%kg_m3_to_R * 10.*epsilon(r_tol) + sv_tol = 5.0e-5*EOS%R_to_kg_m3 * 10.*epsilon(sv_tol) + rho_ref = 1000.0*EOS%kg_m3_to_R + spv_ref = 1.0 / rho_ref + + order = 4 ! This should be 2, 4 or 6. + + do n=1,2 + ! Calculate density values with a wide enough stencil to estimate first and second derivatives + ! with up to 6th order accuracy. Doing this twice with different sizes of pertubations allows + ! the evaluation of whether the finite differences are converging to the calculated values at a + ! rate that is consistent with the order of accuracy of the finite difference forms, and hence + ! the consistency of the calculated values. + do k=-3,3 ; do j=-3,3 ; do i=-3,3 + T(i,j,k) = T_test + n*dT*i + S(i,j,k) = S_test + n*dS*j + p(i,j,k) = p_test + n*dp*k + enddo ; enddo ; enddo + do k=-3,3 ; do j=-3,3 + call calculate_density(T(:,j,k), S(:,j,k), p(:,j,k), rho(:,j,k,n), EOS, rho_ref=rho_ref) + call calculate_spec_vol(T(:,j,k), S(:,j,k), p(:,j,k), spv(:,j,k,n), EOS, spv_ref=spv_ref) + enddo ; enddo + + drho_dT_fd(n) = first_deriv(rho(:,0,0,n), n*dT, order) + drho_dS_fd(n) = first_deriv(rho(0,:,0,n), n*dS, order) + drho_dp_fd(n) = first_deriv(rho(0,0,:,n), n*dp, order) + dSV_dT_fd(n) = first_deriv(spv(:,0,0,n), n*dT, order) + dSV_dS_fd(n) = first_deriv(spv(0,:,0,n), n*dS, order) + if (test_2nd) then + drho_dT_dT_fd(n) = second_deriv(rho(:,0,0,n), n*dT, order) + drho_dS_dS_fd(n) = second_deriv(rho(0,:,0,n), n*dS, order) + drho_dS_dT_fd(n) = derivs_2d(rho(:,:,0,n), n**2*dT*dS, order) + drho_dT_dP_fd(n) = derivs_2d(rho(:,0,:,n), n**2*dT*dP, order) + drho_dS_dP_fd(n) = derivs_2d(rho(0,:,:,n), n**2*dS*dP, order) + endif + enddo + + call calculate_density_derivs(T(0,0,0), S(0,0,0), p(0,0,0), drho_dT, drho_dS, EOS) + ! The first indices here are "0:0" because there is no scalar form of calculate_specific_vol_derivs. + call calculate_specific_vol_derivs(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), dSV_dT, dSV_dS, EOS) + if (test_2nd) & + call calculate_density_second_derivs(T(0,0,0), S(0,0,0), p(0,0,0), & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, EOS) + call calculate_compress(T(0,0,0), S(0,0,0), p(0,0,0), rho_tmp, drho_dp, EOS) + + tol = 1000.0*epsilon(tol) + if (present(spv_check)) then + OK = (abs(spv_check - (spv_ref + spv(0,0,0,1))) < tol*abs(spv_ref + spv(0,0,0,1))) + if (verbose .and. .not.OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + spv_check, spv_ref+spv(0,0,0,1), tol*spv(0,0,0,1) + call MOM_error(WARNING, "The value of "//trim(EOS_name)//" spv disagrees with its check value :"//trim(mesg)) + endif + else + OK = (abs((rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0) < tol) + + if (verbose .and. .not.OK) then + write(mesg, '(ES16.8," and ",ES16.8,", ratio - 1 = ",ES16.8)') & + rho(0,0,0,1), 1.0/(spv_ref + spv(0,0,0,1)) - rho_ref, & + (rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0 + call MOM_error(WARNING, "The values of "//trim(EOS_name)//" rho and 1/spv disagree. "//trim(mesg)) + endif + endif + if (present(rho_check)) then + OK = OK .and. (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) + if (verbose .and. .not.OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + rho_check, rho_ref+rho(0,0,0,1), tol*rho(0,0,0,1) + call MOM_error(WARNING, "The value of "//trim(EOS_name)//" rho disagrees with its check value :"//trim(mesg)) + endif + endif + + ! Account for the factors of terms in the numerator and denominator when estimating roundoff + if (order == 6) then + count_fac = 110.0/60.0 ; count_fac2 = 1088.0/180.0 + elseif (order == 4) then ! Use values appropriate for 4th order schemes. + count_fac = 18.0/12.0 ; count_fac2 = 64.0/12.0 + else ! Use values appropriate for 2nd order schemes. + count_fac = 2.0/2.0 ; count_fac2 = 4.0 + endif + + ! Check for the rate of convergence expected with a 4th or 6th order accurate discretization + ! with a 20% margin of error and a tolerance for contributions from roundoff. + tol_here = tol*abs(drho_dT) + count_fac*r_tol/dT + OK = OK .and. check_FD(drho_dT, drho_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dT", order) + tol_here = tol*abs(drho_dS) + count_fac*r_tol/dS + OK = OK .and. check_FD(drho_dS, drho_dS_fd, tol_here, verbose, trim(EOS_name)//" drho_dS", order) + tol_here = tol*abs(drho_dp) + count_fac*r_tol/dp + OK = OK .and. check_FD(drho_dp, drho_dp_fd, tol_here, verbose, trim(EOS_name)//" drho_dp", order) + tol_here = tol*abs(dSV_dT(1)) + count_fac*sv_tol/dT + OK = OK .and. check_FD(dSV_dT(1), dSV_dT_fd, tol_here, verbose, trim(EOS_name)//" dSV_dT", order) + tol_here = tol*abs(dSV_dS(1)) + count_fac*sv_tol/dS + OK = OK .and. check_FD(dSV_dS(1), dSV_dS_fd, tol_here, verbose, trim(EOS_name)//" dSV_dS", order) + if (test_2nd) then + tol_here = tol*abs(drho_dT_dT) + count_fac2*r_tol/dT**2 + OK = OK .and. check_FD(drho_dT_dT, drho_dT_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dT_dT", order) + ! The curvature in salinity is relatively weak, so looser tolerances are needed for some forms of EOS? + tol_here = 10.0*(tol*abs(drho_dS_dS) + count_fac2*r_tol/dS**2) + OK = OK .and. check_FD(drho_dS_dS, drho_dS_dS_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dS", order) + tol_here = tol*abs(drho_dS_dT) + count_fac**2*r_tol/(dS*dT) + OK = OK .and. check_FD(drho_dS_dT, drho_dS_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dT", order) + tol_here = tol*abs(drho_dT_dP) + count_fac**2*r_tol/(dT*dp) + OK = OK .and. check_FD(drho_dT_dP, drho_dT_dP_fd, tol_here, verbose, trim(EOS_name)//" drho_dT_dP", order) + tol_here = tol*abs(drho_dS_dP) + count_fac**2*r_tol/(dS*dp) + OK = OK .and. check_FD(drho_dS_dP, drho_dS_dP_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dP", order) + endif + + inconsistent = .not.OK + + contains + + !> Return a finite difference estimate of the first derivative of a field in arbitary units [A B-1] + real function first_deriv(R, dx, order) + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in abitrary units [A] + real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + if (order == 6) then ! Find a 6th order accurate first derivative on a regular grid. + first_deriv = (45.0*(R(1)-R(-1)) + (-9.0*(R(2)-R(-2)) + (R(3)-R(-3))) ) / (60.0 * dx) + elseif (order == 4) then ! Find a 4th order accurate first derivative on a regular grid. + first_deriv = (8.0*(R(1)-R(-1)) - (R(2)-R(-2)) ) / (12.0 * dx) + else ! Find a 2nd order accurate first derivative on a regular grid. + first_deriv = (R(1)-R(-1)) / (2.0 * dx) + endif + end function first_deriv + + !> Return a finite difference estimate of the second derivative of a field in arbitary units [A B-2] + real function second_deriv(R, dx, order) + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in abitrary units [A] + real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + if (order == 6) then ! Find a 6th order accurate second derivative on a regular grid. + second_deriv = ( -490.0*R(0) + (270.0*(R(1)+R(-1)) + (-27.0*(R(2)+R(-2)) + 2.0*(R(3)+R(-3))) )) / (180.0 * dx**2) + elseif (order == 4) then ! Find a 4th order accurate second derivative on a regular grid. + second_deriv = ( -30.0*R(0) + (16.0*(R(1)+R(-1)) - (R(2)+R(-2))) ) / (12.0 * dx**2) + else ! Find a 2nd order accurate second derivative on a regular grid. + second_deriv = ( -2.0*R(0) + (R(1)+R(-1)) ) / dx**2 + endif + end function second_deriv + + !> Return a finite difference estimate of the second derivative with respect to two different + !! parameters of a field in arbitary units [A B-2] + real function derivs_2d(R, dxdy, order) + real, intent(in) :: R(-3:3,-3:3) !< The field whose derivative is being taken in abitrary units [A] + real, intent(in) :: dxdy !< The spacing in two directions in parameter space in different arbitrary units [B C] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + real :: dRdx(-3:3) ! The first derivative in one direction times the grid spacing in that direction [A] + integer :: i + + do i=-3,3 + dRdx(i) = first_deriv(R(:,i), 1.0, order) + enddo + derivs_2d = first_deriv(dRdx, dxdy, order) + + end function derivs_2d + + !> Check for the rate of convergence expected with a finite difference discretization + !! with a 20% margin of error and a tolerance for contributions from roundoff. + logical function check_FD(val, val_fd, tol, verbose, field_name, order) + real, intent(in) :: val !< The derivative being checked, in arbitrary units [arbitrary] + real, intent(in) :: val_fd(2) !< Two finite difference estimates of val taken with a spacing + !! in parameter space and twice this spacing, in the same + !! arbitrary units as val [arbitrary] + real, intent(in) :: tol !< An estimated fractional tolerance due to roundoff [arbitrary] + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: field_name !< A name used to describe the field in error messages + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + character(len=200) :: mesg + + check_FD = ( abs(val_fd(1) - val) < (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) ) + + write(mesg, '(ES16.8," and ",ES16.8," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + val, val_fd(1), val - val_fd(1), & + 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & + (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) + ! This message is useful for debugging the two estimates: + ! write(mesg, '(ES16.8," and ",ES16.8," or ",ES16.8," differ by ",2ES16.8," (",2ES10.2"), tol=",ES16.8)') & + ! val, val_fd(1), val_fd(2), val - val_fd(1), val - val_fd(2), & + ! 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & + ! 2.0*(val - val_fd(2)) / (abs(val) + abs(val_fd(2)) + tiny(val)), & + ! (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) + if (verbose .and. .not.check_FD) then + call MOM_error(WARNING, "The values of "//trim(field_name)//" disagree. "//trim(mesg)) + elseif (verbose) then + call MOM_mesg("The values of "//trim(field_name)//" agree: "//trim(mesg)) + endif + end function check_FD + +end function test_EOS_consistency + end module MOM_EOS !> \namespace mom_eos From ca20e2f1ae71a34632bb32a4d8555d94aa8f89f4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Feb 2023 15:09:58 -0500 Subject: [PATCH 49/91] Fix doxygen labels in EOS_Wright_full and _red Changed recently added doxygen labels in the two newly added EOS_Wright_red and EOS_Wright_full modules to avoid reusing names that were already being used by EOS_Wright. All answers are bitwise identical, but the doxygen testing that had been failing for the previous 5 commits is working again. --- src/equation_of_state/MOM_EOS_Wright_full.F90 | 4 ++-- src/equation_of_state/MOM_EOS_Wright_red.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index e79b392cde..f20bd67759 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -942,7 +942,7 @@ end subroutine int_spec_vol_dp_wright_full !> \namespace mom_eos_wright_full !! -!! \section section_EOS_Wright Wright equation of state +!! \section section_EOS_Wright_full Wright equation of state !! !! Wright, 1997, provide an approximation for the in situ density as a function of !! potential temperature, salinity, and pressure. The formula follow the Tumlirz @@ -954,7 +954,7 @@ end subroutine int_spec_vol_dp_wright_full !! Originally coded in 2000 by R. Hallberg. !! Anomaly form coded in 3/18. !! -!! \subsection section_EOS_Wright_references References +!! \subsection section_EOS_Wright_full_references References !! !! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. !! J. Ocean. Atmosph. Tech., 14 (3), 735-740. diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index 4a867468b9..eaf3998be7 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -942,7 +942,7 @@ end subroutine int_spec_vol_dp_wright_red !> \namespace mom_eos_wright_red !! -!! \section section_EOS_Wright Wright equation of state +!! \section section_EOS_Wright_red Wright equation of state !! !! Wright, 1997, provide an approximation for the in situ density as a function of !! potential temperature, salinity, and pressure. The formula follow the Tumlirz @@ -954,7 +954,7 @@ end subroutine int_spec_vol_dp_wright_red !! Originally coded in 2000 by R. Hallberg. !! Anomaly form coded in 3/18. !! -!! \subsection section_EOS_Wright_references References +!! \subsection section_EOS_Wright_red_references References !! !! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. !! J. Ocean. Atmosph. Tech., 14 (3), 735-740. From 52f567805a1c908b3c1970330412b148d76c16a9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Feb 2023 15:28:45 -0500 Subject: [PATCH 50/91] *+NEMO equation of state self-consistency Corrected numerous issues with the NEMO equation of state so that it is now self consistent: - Modified how coefficients are set in MOM_EOS_NEMO so that they are guaranteed to be internally self-consistent, as verified by the EOS unit tests confirming that the first derivatives of density with temperature and salinity are now consistent with the equation of state. Previously these had only been consistent to about 7 decimal places, and hence the EOS unit tests were failing for the NEMO equation of state. - Added new public interfaces to calculate_density_second_derivs_NEMO, which had previously been missing. - Added code for calculate_compress_nemo that is explicitly derived from the NEMO EOS. The previous version of calculate_compress_nemo had worked only approximately via a call to the gsw package With these changes, the NEMO EOS routines are now passing the consistency testing in the EOS unit tests. Answers will change for configurations that use the NEMO EOS to calculate any derivatives, and there are new public interfaces, but it does not appear that the NEMO equation of state is in use yet, at least it is not being used at EMC, FSU, GFDL, NASA GSFC, NCAR or in the ESMG configurations. This commit addresses the issue raised at github.com/mom-ocean/MOM6/issues/405. --- src/equation_of_state/MOM_EOS.F90 | 36 +- src/equation_of_state/MOM_EOS_NEMO.F90 | 441 ++++++++++++++++++------- 2 files changed, 344 insertions(+), 133 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 345641e5d0..db60214373 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -28,6 +28,7 @@ module MOM_EOS use MOM_EOS_UNESCO, only : calculate_compress_unesco use MOM_EOS_NEMO, only : calculate_density_nemo use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo +use MOM_EOS_NEMO, only : calculate_density_second_derivs_NEMO use MOM_EOS_NEMO, only : calculate_compress_nemo use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 @@ -267,8 +268,8 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r call MOM_error(FATAL, "calculate_stanley_density_scalar: "//& "EOS_UNESCO is not set up to calculate second derivatives yet.") case (EOS_NEMO) - call MOM_error(FATAL, "calculate_stanley_density_scalar: "//& - "EOS_NEMO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_NEMO(T_scale*T, S_scale*S, p_scale*pressure, & + d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) @@ -377,8 +378,8 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh "EOS_UNESCO is not set up to calculate second derivatives yet.") case (EOS_NEMO) call calculate_density_NEMO(T, S, pressure, rho, start, npts, rho_ref) - call MOM_error(FATAL, "calculate_stanley_density_array: "//& - "EOS_NEMO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_NEMO(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & @@ -531,8 +532,8 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, "EOS_UNESCO is not set up to calculate second derivatives yet.") case (EOS_NEMO) call calculate_density_NEMO(Ta, Sa, pres, rho, is, npts, rho_reference) - call MOM_error(FATAL, "calculate_stanley_density_1d: "//& - "EOS_NEMO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_NEMO(Ta, Sa, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, is, npts) case (EOS_TEOS10) call calculate_density_teos10(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_teos10(Ta, Sa, pres, d2RdSS, d2RdST, & @@ -1054,8 +1055,8 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d call MOM_error(FATAL, "calculate_density_second_derivs: "//& "EOS_UNESCO is not set up to calculate second derivatives yet.") case (EOS_NEMO) - call MOM_error(FATAL, "calculate_density_second_derivs: "//& - "EOS_NEMO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_NEMO(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1085,8 +1086,8 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d call MOM_error(FATAL, "calculate_density_second_derivs: "//& "EOS_UNESCO is not set up to calculate second derivatives yet.") case (EOS_NEMO) - call MOM_error(FATAL, "calculate_density_second_derivs: "//& - "EOS_NEMO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1170,8 +1171,8 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr call MOM_error(FATAL, "calculate_density_second_derivs: "//& "EOS_UNESCO is not set up to calculate second derivatives yet.") case (EOS_NEMO) - call MOM_error(FATAL, "calculate_density_second_derivs: "//& - "EOS_NEMO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) @@ -2008,12 +2009,11 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - ! The NEMO equation of state is not passing some self consistency tests yet. - ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_NEMO) - ! fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "NEMO", & - ! rho_check=1027.4238566366823*EOS_tmp%kg_m3_to_R) - ! if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") - ! EOS_unit_tests = EOS_unit_tests .or. fail + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_NEMO) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "NEMO", & + rho_check=1027.4238566366823*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail ! The TEOS10 equation of state is not passing some self consistency tests yet. ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index dee2bc48bf..b0515ac768 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -3,24 +3,14 @@ module MOM_EOS_NEMO ! This file is part of MOM6. See LICENSE.md for the license. -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the formulae provided by NEMO developer Roquet * -!* in a private communication , Roquet et al, Ocean Modelling (2015) * -!* Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015. * -!* Accurate polynomial expressions for the density and specific volume* -!* of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. * -!* These algorithms are NOT from the standard NEMO package!! * -!*********************************************************************** - !use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt -use gsw_mod_toolbox, only : gsw_rho_first_derivatives implicit none ; private public calculate_compress_nemo, calculate_density_nemo public calculate_density_derivs_nemo public calculate_density_scalar_nemo, calculate_density_array_nemo +public calculate_density_second_derivs_nemo !> Compute the in situ density of sea water [kg m-3], or its anomaly with respect to !! a reference density, from absolute salinity [g kg-1], conservative temperature [degC], @@ -35,6 +25,12 @@ module MOM_EOS_NEMO module procedure calculate_density_derivs_scalar_nemo, calculate_density_derivs_array_nemo end interface calculate_density_derivs_nemo +!> Compute the second derivatives of density with various combinations +!! of temperature, salinity, and pressure +interface calculate_density_second_derivs_nemo + module procedure calculate_density_second_derivs_scalar_nemo, calculate_density_second_derivs_array_nemo +end interface calculate_density_second_derivs_nemo + real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar [Pa dbar-1] !>@{ Parameters in the NEMO equation of state real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] @@ -103,77 +99,77 @@ module MOM_EOS_NEMO real, parameter :: EOS103 = -1.8507636718e-02 ! Coefficient of the EOS proportional to zs * zp**3 [kg m-3] real, parameter :: EOS013 = 3.7969820455e-01 ! Coefficient of the EOS proportional to zt * zp**3 [kg m-3] -real, parameter :: ALP000 = -6.5025362670e-01 ! Constant in the drho_dT fit [kg m-3 degC-1] -real, parameter :: ALP100 = 1.6320471316 ! Coefficient of the drho_dT fit zs term [kg m-3 degC-1] -real, parameter :: ALP200 = -2.0442606277 ! Coefficient of the drho_dT fit zs**2 term [kg m-3 degC-1] -real, parameter :: ALP300 = 1.4222011580 ! Coefficient of the drho_dT fit zs**3 term [kg m-3 degC-1] -real, parameter :: ALP400 = -4.4204535284e-01 ! Coefficient of the drho_dT fit zs**4 term [kg m-3 degC-1] -real, parameter :: ALP500 = 4.7983755487e-02 ! Coefficient of the drho_dT fit zs**5 term [kg m-3 degC-1] -real, parameter :: ALP010 = 1.8537085209 ! Coefficient of the drho_dT fit zt term [kg m-3 degC-1] -real, parameter :: ALP110 = -3.0774129064 ! Coefficient of the drho_dT fit zs * zt term [kg m-3 degC-1] -real, parameter :: ALP210 = 3.0181275751 ! Coefficient of the drho_dT fit zs**2 * zt term [kg m-3 degC-1] -real, parameter :: ALP310 = -1.4565010626 ! Coefficient of the drho_dT fit zs**3 * zt term [kg m-3 degC-1] -real, parameter :: ALP410 = 2.7361846370e-01 ! Coefficient of the drho_dT fit zs**4 * zt term [kg m-3 degC-1] -real, parameter :: ALP020 = -1.6246342147 ! Coefficient of the drho_dT fit zt**2 term [kg m-3 degC-1] -real, parameter :: ALP120 = 2.5086831352 ! Coefficient of the drho_dT fit zs * zt**2 term [kg m-3 degC-1] -real, parameter :: ALP220 = -1.4787808849 ! Coefficient of the drho_dT fit zs**2 * zt**2 term [kg m-3 degC-1] -real, parameter :: ALP320 = 2.3807209899e-01 ! Coefficient of the drho_dT fit zs**3 * zt**2 term [kg m-3 degC-1] -real, parameter :: ALP030 = 8.3627885467e-01 ! Coefficient of the drho_dT fit zt**3 term [kg m-3 degC-1] -real, parameter :: ALP130 = -1.1311538584 ! Coefficient of the drho_dT fit zs * zt**3 term [kg m-3 degC-1] -real, parameter :: ALP230 = 5.3563304045e-01 ! Coefficient of the drho_dT fit zs**2 * zt**3 term [kg m-3 degC-1] -real, parameter :: ALP040 = -6.7560904739e-02 ! Coefficient of the drho_dT fit zt**4 term [kg m-3 degC-1] -real, parameter :: ALP140 = -6.0212475204e-02 ! Coefficient of the drho_dT fit zs* * zt**4 term [kg m-3 degC-1] -real, parameter :: ALP050 = 2.8625353333e-02 ! Coefficient of the drho_dT fit zt**5 term [kg m-3 degC-1] -real, parameter :: ALP001 = 3.3340752782e-01 ! Coefficient of the drho_dT fit zp term [kg m-3 degC-1] -real, parameter :: ALP101 = 1.1217528644e-01 ! Coefficient of the drho_dT fit zs * zp term [kg m-3 degC-1] -real, parameter :: ALP201 = -1.2510649515e-01 ! Coefficient of the drho_dT fit zs**2 * zp term [kg m-3 degC-1] -real, parameter :: ALP301 = 1.6349760916e-02 ! Coefficient of the drho_dT fit zs**3 * zp term [kg m-3 degC-1] -real, parameter :: ALP011 = -3.3540239802e-01 ! Coefficient of the drho_dT fit zt * zp term [kg m-3 degC-1] -real, parameter :: ALP111 = -1.7531540640e-01 ! Coefficient of the drho_dT fit zs * zt * zp term [kg m-3 degC-1] -real, parameter :: ALP211 = 9.3976864981e-02 ! Coefficient of the drho_dT fit zs**2 * zt * zp term [kg m-3 degC-1] -real, parameter :: ALP021 = 1.8487252150e-01 ! Coefficient of the drho_dT fit zt**2 * zp term [kg m-3 degC-1] -real, parameter :: ALP121 = 4.1307825959e-02 ! Coefficient of the drho_dT fit zs * zt**2 * zp term [kg m-3 degC-1] -real, parameter :: ALP031 = -5.5927935970e-02 ! Coefficient of the drho_dT fit zt**3 * zp term [kg m-3 degC-1] -real, parameter :: ALP002 = -5.1410778748e-02 ! Coefficient of the drho_dT fit zp**2 term [kg m-3 degC-1] -real, parameter :: ALP102 = 5.3278413794e-03 ! Coefficient of the drho_dT fit zs * zp**2 term [kg m-3 degC-1] -real, parameter :: ALP012 = 6.2099915132e-02 ! Coefficient of the drho_dT fit zt * zp**2 term [kg m-3 degC-1] -real, parameter :: ALP003 = -9.4924551138e-03 ! Coefficient of the drho_dT fit zp**3 term [kg m-3 degC-1] - -real, parameter :: BET000 = 1.0783203594e+01 ! Constant in the drho_dS fit [kg m-3 ppt-1] -real, parameter :: BET100 = -4.4452095908e+01 ! Coefficient of the drho_dS fit zs term [kg m-3 ppt-1] -real, parameter :: BET200 = 7.6048755820e+01 ! Coefficient of the drho_dS fit zs**2 term [kg m-3 ppt-1] -real, parameter :: BET300 = -6.3944280668e+01 ! Coefficient of the drho_dS fit zs**3 term [kg m-3 ppt-1] -real, parameter :: BET400 = 2.6890441098e+01 ! Coefficient of the drho_dS fit zs**4 term [kg m-3 ppt-1] -real, parameter :: BET500 = -4.5221697773 ! Coefficient of the drho_dS fit zs**5 term [kg m-3 ppt-1] -real, parameter :: BET010 = -8.1219372432e-01 ! Coefficient of the drho_dS fit zt term [kg m-3 ppt-1] -real, parameter :: BET110 = 2.0346663041 ! Coefficient of the drho_dS fit zs * zt term [kg m-3 ppt-1] -real, parameter :: BET210 = -2.1232895170 ! Coefficient of the drho_dS fit zs**2 * zt term [kg m-3 ppt-1] -real, parameter :: BET310 = 8.7994140485e-01 ! Coefficient of the drho_dS fit zs**3 * zt term [kg m-3 ppt-1] -real, parameter :: BET410 = -1.1939638360e-01 ! Coefficient of the drho_dS fit zs**4 * zt term [kg m-3 ppt-1] -real, parameter :: BET020 = 7.6574242289e-01 ! Coefficient of the drho_dS fit zt**2 term [kg m-3 ppt-1] -real, parameter :: BET120 = -1.5019813020 ! Coefficient of the drho_dS fit zs * zt**2 term [kg m-3 ppt-1] -real, parameter :: BET220 = 1.0872489522 ! Coefficient of the drho_dS fit zs**2 * zt**2 term [kg m-3 ppt-1] -real, parameter :: BET320 = -2.7233429080e-01 ! Coefficient of the drho_dS fit zs**3 * zt**2 term [kg m-3 ppt-1] -real, parameter :: BET030 = -4.1615152308e-01 ! Coefficient of the drho_dS fit zt**3 term [kg m-3 ppt-1] -real, parameter :: BET130 = 4.9061350869e-01 ! Coefficient of the drho_dS fit zs * zt**3 term [kg m-3 ppt-1] -real, parameter :: BET230 = -1.1847737788e-01 ! Coefficient of the drho_dS fit zs**2 * zt**3 term [kg m-3 ppt-1] -real, parameter :: BET040 = 1.4073062708e-01 ! Coefficient of the drho_dS fit zt**4 term [kg m-3 ppt-1] -real, parameter :: BET140 = -1.3327978879e-01 ! Coefficient of the drho_dS fit zs * zt**4 term [kg m-3 ppt-1] -real, parameter :: BET050 = 5.9929880134e-03 ! Coefficient of the drho_dS fit zt**5 term [kg m-3 ppt-1] -real, parameter :: BET001 = -5.2937873009e-01 ! Coefficient of the drho_dS fit zp term [kg m-3 ppt-1] -real, parameter :: BET101 = 1.2634116779 ! Coefficient of the drho_dS fit zs * zp term [kg m-3 ppt-1] -real, parameter :: BET201 = -1.1547328025 ! Coefficient of the drho_dS fit zs**2 * zp term [kg m-3 ppt-1] -real, parameter :: BET301 = 3.2870876279e-01 ! Coefficient of the drho_dS fit zs**3 * zp term [kg m-3 ppt-1] -real, parameter :: BET011 = -5.5824407214e-02 ! Coefficient of the drho_dS fit zt * zp term [kg m-3 ppt-1] -real, parameter :: BET111 = 1.2451933313e-01 ! Coefficient of the drho_dS fit zs * zt * zp term [kg m-3 ppt-1] -real, parameter :: BET211 = -2.4409539932e-02 ! Coefficient of the drho_dS fit zs**2 * zt * zp term [kg m-3 ppt-1] -real, parameter :: BET021 = 4.3623149752e-02 ! Coefficient of the drho_dS fit zt**2 * zp term [kg m-3 ppt-1] -real, parameter :: BET121 = -4.6767901790e-02 ! Coefficient of the drho_dS fit zs * zt**2 * zp term [kg m-3 ppt-1] -real, parameter :: BET031 = -6.8523260060e-03 ! Coefficient of the drho_dS fit zt**3 * zp term [kg m-3 ppt-1] -real, parameter :: BET002 = -6.1618945251e-02 ! Coefficient of the drho_dS fit zp**2 term [kg m-3 ppt-1] -real, parameter :: BET102 = 6.2255521644e-02 ! Coefficient of the drho_dS fit zs * zp**2 term [kg m-3 ppt-1] -real, parameter :: BET012 = -2.6514181169e-03 ! Coefficient of the drho_dS fit zt * zp**2 term [kg m-3 ppt-1] -real, parameter :: BET003 = -2.3025968587e-04 ! Coefficient of the drho_dS fit zp**3 term [kg m-3 ppt-1] +real, parameter :: ALP000 = EOS010*r1_T0 ! Constant in the drho_dT fit [kg m-3 degC-1] +real, parameter :: ALP100 = EOS110*r1_T0 ! Coefficient of the drho_dT fit zs term [kg m-3 degC-1] +real, parameter :: ALP200 = EOS210*r1_T0 ! Coefficient of the drho_dT fit zs**2 term [kg m-3 degC-1] +real, parameter :: ALP300 = EOS310*r1_T0 ! Coefficient of the drho_dT fit zs**3 term [kg m-3 degC-1] +real, parameter :: ALP400 = EOS410*r1_T0 ! Coefficient of the drho_dT fit zs**4 term [kg m-3 degC-1] +real, parameter :: ALP500 = EOS510*r1_T0 ! Coefficient of the drho_dT fit zs**5 term [kg m-3 degC-1] +real, parameter :: ALP010 = 2.*EOS020*r1_T0 ! Coefficient of the drho_dT fit zt term [kg m-3 degC-1] +real, parameter :: ALP110 = 2.*EOS120*r1_T0 ! Coefficient of the drho_dT fit zs * zt term [kg m-3 degC-1] +real, parameter :: ALP210 = 2.*EOS220*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt term [kg m-3 degC-1] +real, parameter :: ALP310 = 2.*EOS320*r1_T0 ! Coefficient of the drho_dT fit zs**3 * zt term [kg m-3 degC-1] +real, parameter :: ALP410 = 2.*EOS420*r1_T0 ! Coefficient of the drho_dT fit zs**4 * zt term [kg m-3 degC-1] +real, parameter :: ALP020 = 3.*EOS030*r1_T0 ! Coefficient of the drho_dT fit zt**2 term [kg m-3 degC-1] +real, parameter :: ALP120 = 3.*EOS130*r1_T0 ! Coefficient of the drho_dT fit zs * zt**2 term [kg m-3 degC-1] +real, parameter :: ALP220 = 3.*EOS230*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt**2 term [kg m-3 degC-1] +real, parameter :: ALP320 = 3.*EOS330*r1_T0 ! Coefficient of the drho_dT fit zs**3 * zt**2 term [kg m-3 degC-1] +real, parameter :: ALP030 = 4.*EOS040*r1_T0 ! Coefficient of the drho_dT fit zt**3 term [kg m-3 degC-1] +real, parameter :: ALP130 = 4.*EOS140*r1_T0 ! Coefficient of the drho_dT fit zs * zt**3 term [kg m-3 degC-1] +real, parameter :: ALP230 = 4.*EOS240*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt**3 term [kg m-3 degC-1] +real, parameter :: ALP040 = 5.*EOS050*r1_T0 ! Coefficient of the drho_dT fit zt**4 term [kg m-3 degC-1] +real, parameter :: ALP140 = 5.*EOS150*r1_T0 ! Coefficient of the drho_dT fit zs* * zt**4 term [kg m-3 degC-1] +real, parameter :: ALP050 = 6.*EOS060*r1_T0 ! Coefficient of the drho_dT fit zt**5 term [kg m-3 degC-1] +real, parameter :: ALP001 = EOS011*r1_T0 ! Coefficient of the drho_dT fit zp term [kg m-3 degC-1] +real, parameter :: ALP101 = EOS111*r1_T0 ! Coefficient of the drho_dT fit zs * zp term [kg m-3 degC-1] +real, parameter :: ALP201 = EOS211*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zp term [kg m-3 degC-1] +real, parameter :: ALP301 = EOS311*r1_T0 ! Coefficient of the drho_dT fit zs**3 * zp term [kg m-3 degC-1] +real, parameter :: ALP011 = 2.*EOS021*r1_T0 ! Coefficient of the drho_dT fit zt * zp term [kg m-3 degC-1] +real, parameter :: ALP111 = 2.*EOS121*r1_T0 ! Coefficient of the drho_dT fit zs * zt * zp term [kg m-3 degC-1] +real, parameter :: ALP211 = 2.*EOS221*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt * zp term [kg m-3 degC-1] +real, parameter :: ALP021 = 3.*EOS031*r1_T0 ! Coefficient of the drho_dT fit zt**2 * zp term [kg m-3 degC-1] +real, parameter :: ALP121 = 3.*EOS131*r1_T0 ! Coefficient of the drho_dT fit zs * zt**2 * zp term [kg m-3 degC-1] +real, parameter :: ALP031 = 4.*EOS041*r1_T0 ! Coefficient of the drho_dT fit zt**3 * zp term [kg m-3 degC-1] +real, parameter :: ALP002 = EOS012*r1_T0 ! Coefficient of the drho_dT fit zp**2 term [kg m-3 degC-1] +real, parameter :: ALP102 = EOS112*r1_T0 ! Coefficient of the drho_dT fit zs * zp**2 term [kg m-3 degC-1] +real, parameter :: ALP012 = 2.*EOS022*r1_T0 ! Coefficient of the drho_dT fit zt * zp**2 term [kg m-3 degC-1] +real, parameter :: ALP003 = EOS013*r1_T0 ! Coefficient of the drho_dT fit zp**3 term [kg m-3 degC-1] + +real, parameter :: BET000 = 0.5*EOS100*r1_S0 ! Constant in the drho_dS fit [kg m-3 ppt-1] +real, parameter :: BET100 = EOS200*r1_S0 ! Coefficient of the drho_dS fit zs term [kg m-3 ppt-1] +real, parameter :: BET200 = 1.5*EOS300*r1_S0 ! Coefficient of the drho_dS fit zs**2 term [kg m-3 ppt-1] +real, parameter :: BET300 = 2.0*EOS400*r1_S0 ! Coefficient of the drho_dS fit zs**3 term [kg m-3 ppt-1] +real, parameter :: BET400 = 2.5*EOS500*r1_S0 ! Coefficient of the drho_dS fit zs**4 term [kg m-3 ppt-1] +real, parameter :: BET500 = 3.0*EOS600*r1_S0 ! Coefficient of the drho_dS fit zs**5 term [kg m-3 ppt-1] +real, parameter :: BET010 = 0.5*EOS110*r1_S0 ! Coefficient of the drho_dS fit zt term [kg m-3 ppt-1] +real, parameter :: BET110 = EOS210*r1_S0 ! Coefficient of the drho_dS fit zs * zt term [kg m-3 ppt-1] +real, parameter :: BET210 = 1.5*EOS310*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt term [kg m-3 ppt-1] +real, parameter :: BET310 = 2.0*EOS410*r1_S0 ! Coefficient of the drho_dS fit zs**3 * zt term [kg m-3 ppt-1] +real, parameter :: BET410 = 2.5*EOS510*r1_S0 ! Coefficient of the drho_dS fit zs**4 * zt term [kg m-3 ppt-1] +real, parameter :: BET020 = 0.5*EOS120*r1_S0 ! Coefficient of the drho_dS fit zt**2 term [kg m-3 ppt-1] +real, parameter :: BET120 = EOS220*r1_S0 ! Coefficient of the drho_dS fit zs * zt**2 term [kg m-3 ppt-1] +real, parameter :: BET220 = 1.5*EOS320*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt**2 term [kg m-3 ppt-1] +real, parameter :: BET320 = 2.0*EOS420*r1_S0 ! Coefficient of the drho_dS fit zs**3 * zt**2 term [kg m-3 ppt-1] +real, parameter :: BET030 = 0.5*EOS130*r1_S0 ! Coefficient of the drho_dS fit zt**3 term [kg m-3 ppt-1] +real, parameter :: BET130 = EOS230*r1_S0 ! Coefficient of the drho_dS fit zs * zt**3 term [kg m-3 ppt-1] +real, parameter :: BET230 = 1.5*EOS330*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt**3 term [kg m-3 ppt-1] +real, parameter :: BET040 = 0.5*EOS140*r1_S0 ! Coefficient of the drho_dS fit zt**4 term [kg m-3 ppt-1] +real, parameter :: BET140 = EOS240*r1_S0 ! Coefficient of the drho_dS fit zs * zt**4 term [kg m-3 ppt-1] +real, parameter :: BET050 = 0.5*EOS150*r1_S0 ! Coefficient of the drho_dS fit zt**5 term [kg m-3 ppt-1] +real, parameter :: BET001 = 0.5*EOS101*r1_S0 ! Coefficient of the drho_dS fit zp term [kg m-3 ppt-1] +real, parameter :: BET101 = EOS201*r1_S0 ! Coefficient of the drho_dS fit zs * zp term [kg m-3 ppt-1] +real, parameter :: BET201 = 1.5*EOS301*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zp term [kg m-3 ppt-1] +real, parameter :: BET301 = 2.0*EOS401*r1_S0 ! Coefficient of the drho_dS fit zs**3 * zp term [kg m-3 ppt-1] +real, parameter :: BET011 = 0.5*EOS111*r1_S0 ! Coefficient of the drho_dS fit zt * zp term [kg m-3 ppt-1] +real, parameter :: BET111 = EOS211*r1_S0 ! Coefficient of the drho_dS fit zs * zt * zp term [kg m-3 ppt-1] +real, parameter :: BET211 = 1.5*EOS311*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt * zp term [kg m-3 ppt-1] +real, parameter :: BET021 = 0.5*EOS121*r1_S0 ! Coefficient of the drho_dS fit zt**2 * zp term [kg m-3 ppt-1] +real, parameter :: BET121 = EOS221*r1_S0 ! Coefficient of the drho_dS fit zs * zt**2 * zp term [kg m-3 ppt-1] +real, parameter :: BET031 = 0.5*EOS131*r1_S0 ! Coefficient of the drho_dS fit zt**3 * zp term [kg m-3 ppt-1] +real, parameter :: BET002 = 0.5*EOS102*r1_S0 ! Coefficient of the drho_dS fit zp**2 term [kg m-3 ppt-1] +real, parameter :: BET102 = EOS202*r1_S0 ! Coefficient of the drho_dS fit zs * zp**2 term [kg m-3 ppt-1] +real, parameter :: BET012 = 0.5*EOS112*r1_S0 ! Coefficient of the drho_dS fit zt * zp**2 term [kg m-3 ppt-1] +real, parameter :: BET003 = 0.5*EOS103*r1_S0 ! Coefficient of the drho_dS fit zp**3 term [kg m-3 ppt-1] !>@} contains @@ -231,17 +227,18 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re real :: zs0 ! Salinity dependent density at the surface pressure and temperature [kg m-3] integer :: j + ! The following algorithm was published by Roquet et al. (2015), intended for use + ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. do j=start,start+npts-1 - ! Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) ! Convert practical salinity to absolute salinity [g kg--1] - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] - zp = pressure(j) * Pa2db ! Convert pressure from Pascals to decibars [dbar] + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] - !The following algorithm was provided by Roquet in a private communication. - !It is not necessarily the algorithm used in NEMO ocean! - zp = zp * r1_P0 ! pressure normalized by a plausible range of pressure in the ocean [nondim] - zt = zt * r1_T0 ! temperature normalized by a plausible oceanic range [nondim] - zs = SQRT( ABS( zs + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + ! The next two lines should be used if it is necessary to convert potential temperature and + ! pratical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. zn3 = EOS013*zt & & + EOS103*zs+EOS003 @@ -309,16 +306,16 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, integer :: j do j=start,start+npts-1 - ! Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) ! Convert practical salinity to absolute salinity [g kg--1] - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] - zp = pressure(j) * Pa2db ! Convert pressure from Pascals to decibars [dbar] - - !The following algorithm was provided by Roquet in a private communication. - !It is not necessarily the algorithm used in NEMO ocean! - zp = zp * r1_P0 ! pressure normalized by a plausible range of pressure in the ocean [nondim] - zt = zt * r1_T0 ! temperature normalized by a plausible oceanic range [nondim] - zs = SQRT( ABS( zs + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! pratical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + ! ! alpha zn3 = ALP003 @@ -339,7 +336,7 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, ! zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + zn0 ! - drho_dT(j) = -zn + drho_dT(j) = zn ! ! beta ! @@ -410,23 +407,237 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zs ! Absolute salinity [g kg-1] - real :: zt ! Conservative temperature [degC] - real :: zp ! Pressure converted to decibars [dbar] + real :: zp ! Pressure normalized by an assumed pressure range [nondim] + real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salnity range [nondim] + real :: dzr0_dp ! Derivative of the pressure-dependent reference density profile with normalized pressure [kg m-3] + real :: dzn_dp ! Derivative of the density anomaly from the reference profile with normalized pressure [kg m-3] + real :: zr0 ! The pressure-dependent (but temperature and salinity independent) reference density profile [kg m-3] + real :: zn ! Density anomaly from the reference profile [kg m-3] + real :: zn0 ! A contribution to density from temperature and salinity anomalies at the surface pressure [kg m-3] + real :: zn1 ! A temperature and salinity dependent density contribution proportional to pressure [kg m-3] + real :: zn2 ! A temperature and salinity dependent density contribution proportional to pressure^2 [kg m-3] + real :: zn3 ! A temperature and salinity dependent density contribution proportional to pressure^3 [kg m-3] + real :: zs0 ! Salinity dependent density at the surface pressure and temperature [kg m-3] integer :: j - call calculate_density_array_nemo(T, S, pressure, rho, start, npts) - ! - !NOTE: The following calculates the TEOS10 approximation to compressibility - ! since the corresponding NEMO approximation is not available yet. - ! + ! The following algorithm was published by Roquet et al. (2015), intended for use + ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. do j=start,start+npts-1 - ! Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) ! Convert practical salinity to absolute salinity [g kg--1] - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] - zp = pressure(j) * Pa2db ! Convert pressure from Pascals to decibars [dbar] - call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! pratical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + zn3 = EOS013*zt + EOS103*zs + EOS003 + + zn2 = (EOS022*zt & + & + EOS112*zs + EOS012)*zt & + & + (EOS202*zs + EOS102)*zs + EOS002 + + zn1 = (((EOS041*zt & + & + EOS131*zs + EOS031)*zt & + & + (EOS221*zs + EOS121)*zs + EOS021)*zt & + & + ((EOS311*zs + EOS211)*zs + EOS111)*zs + EOS011)*zt & + & + (((EOS401*zs + EOS301)*zs + EOS201)*zs + EOS101)*zs + EOS001 + + zn0 = (((((EOS060*zt & + & + EOS150*zs + EOS050)*zt & + & + (EOS240*zs + EOS140)*zs + EOS040)*zt & + & + ((EOS330*zs + EOS230)*zs + EOS130)*zs + EOS030)*zt & + & + (((EOS420*zs + EOS320)*zs + EOS220)*zs + EOS120)*zs + EOS020)*zt & + & + ((((EOS510*zs + EOS410)*zs + EOS310)*zs + EOS210)*zs + EOS110)*zs + EOS010)*zt + + zs0 = (((((EOS600*zs + EOS500)*zs + EOS400)*zs + EOS300)*zs + EOS200)*zs + EOS100)*zs + EOS000 + + zr0 = (((((R05*zp + R04)*zp + R03)*zp + R02)*zp + R01)*zp + R00)*zp + + zn = ( ( zn3*zp + zn2 )*zp + zn1 )*zp + (zn0 + zs0) + rho(j) = ( zn + zr0 ) ! density + + dzr0_dp = ((((6.*R05*zp + 5.*R04)*zp + 4.*R03)*zp + 3.*R02)*zp + 2.*R01)*zp + R00 + dzn_dp = ( 3.*zn3*zp + 2.*zn2 )*zp + zn1 + drho_dp(j) = ( dzn_dp + dzr0_dp ) * (Pa2db*r1_P0) ! density + enddo end subroutine calculate_compress_nemo + +!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. +subroutine calculate_density_second_derivs_array_NEMO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] + real, dimension(:), intent(in ) :: S !< Salinity [PSU] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + + ! Local variables + real :: zp ! Pressure normalized by an assumed pressure range [nondim] + real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salnity range [nondim] + real :: I_s ! The inverse of zs [nondim] + real :: dzr0_dp ! Derivative of the pressure-dependent reference density profile with normalized pressure [kg m-3] + real :: dzn_dp ! Derivative of the density anomaly from the reference profile with normalized pressure [kg m-3] + real :: dzn_ds ! Derivative of the density anomaly from the reference profile with zs [kg m-3] + real :: zr0 ! The pressure-dependent (but temperature and salinity independent) reference density profile [kg m-3] + real :: zn ! Density anomaly from the reference profile [kg m-3] + real :: zn0 ! A contribution to one of the second derivatives that is independent of pressure [various] + real :: zn1 ! A contribution to one of the second derivatives that is proportional to pressure [various] + real :: zn2 ! A contribution to one of the second derivatives that is proportional to pressure^2 [various] + real :: zn3 ! A temperature and salinity dependent density contribution proportional to pressure^3 [various] + integer :: j + + do j = start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = P(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! pratical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + I_s = 1.0 / zs + + ! Find drho_ds_ds + zn3 = -EOS103*I_s**2 + zn2 = -(EOS112*zt + EOS102)*I_s**2 + zn1 = (3.*EOS311*zt + (8.*EOS401*zs + 3.*EOS301) ) & + - ( ((EOS131*zt + EOS121)*zt + EOS111)*zt + EOS101 )*I_s**2 + zn0 = ( (( 3.*EOS330*zt + (8.*EOS420*zs + 3.*EOS320))*zt + & + ((15.*EOS510*zs + 8.*EOS410)*zs + 3.*EOS310))*zt + & + (((24.*EOS600*zs + 15.*EOS500)*zs + 8.*EOS400)*zs + 3.*EOS300) ) & + - ( ((((EOS150*zt + EOS140)*zt + EOS130)*zt + EOS120)*zt + EOS110)*zt + EOS100 )*I_s**2 + zn = ( ( zn3 * zp + zn2) * zp + zn1 ) * zp + zn0 + drho_dS_dS(j) = (0.5*r1_S0)**2 * (zn * I_s) + + ! Find drho_ds_dt + zn2 = EOS112 + zn1 = ((3.*EOS131)*zt + (4.*EOS221*zs + 2.*EOS121))*zt + & + ((3.*EOS311*zs + 2.*EOS211)*zs + EOS111) + zn0 = (((5.*EOS150*zt + (8.*EOS240*zs + 4.*EOS140))*zt + & + ((9.*EOS330*zs + 6.*EOS230)*zs + 3.*EOS130))*zt + & + ((((8.*EOS420*zs + 6.*EOS320)*zs + 4.*EOS220)*zs + 2.*EOS120)))*zt + & + ((((5.*EOS510*zs + 4.*EOS410)*zs + 3.*EOS310)*zs + 2.*EOS210)*zs + EOS110) + zn = ( zn2 * zp + zn1 ) * zp + zn0 + drho_ds_dt(j) = (0.5*r1_S0*r1_T0) * (zn * I_s) + + ! Find drho_dt_dt + zn2 = 2.*EOS022 + zn1 = (12.*EOS041*zt + 6.*(EOS131*zs + EOS031))*zt + & + 2.*((EOS221*zs + EOS121)*zs + EOS021) + zn0 = (((30.*EOS060*zt + 20.*(EOS150*zs + EOS050))*zt + & + 12.*((EOS240*zs + EOS140)*zs + EOS040))*zt + & + 6.*(((EOS330*zs + EOS230)*zs + EOS130)*zs + EOS030))*zt + & + 2.*((((EOS420*zs + EOS320)*zs + EOS220)*zs + EOS120)*zs + EOS020) + zn = ( zn2 * zp + zn1 ) * zp + zn0 + drho_dt_dt(j) = zn * r1_T0**2 + + ! Find drho_ds_dp + zn3 = EOS103 + zn2 = EOS112*zt + (2.*EOS202*zs + EOS102) + zn1 = ((EOS131*zt + (2.*EOS221*zs + EOS121))*zt + ((3.*EOS311*zs + 2.*EOS211)*zs + EOS111))*zt + & + (((4.*EOS401*zs + 3.*EOS301)*zs + 2.*EOS201)*zs + EOS101) + dzn_dp = ( ( 3.*zn3 * zp + 2.*zn2 ) * zp + zn1 ) + drho_ds_dp(j) = ( dzn_dp * I_s ) * (0.5*r1_S0 * Pa2db*r1_P0) ! Second derivative of density + + + ! Find drho_dt_dp + zn3 = EOS013 + zn2 = 2.*EOS022*zt + (EOS112*zs + EOS012) + zn1 = ((4.*EOS041*zt + 3.*(EOS131*zs + EOS031))*zt + 2.*((EOS221*zs + EOS121)*zs + EOS021))*zt + & + (((EOS311*zs + EOS211)*zs + EOS111)*zs + EOS011) + dzn_dp = ( ( 3.*zn3 * zp + 2.*zn2 ) * zp + zn1 ) + drho_dt_dp(j) = ( dzn_dp ) * (Pa2db*r1_P0* r1_T0) ! Second derivative of density + enddo + +end subroutine calculate_density_second_derivs_array_NEMO + +!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. +!! +!! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar +subroutine calculate_density_second_derivs_scalar_NEMO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Potential temperature referenced to 0 dbar + real, intent(in ) :: S !< Salinity [PSU] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 PSU-2] + real, dimension(1) :: drdsdt ! The second derivative of density with salinity and + ! temperature [kg m-3 PSU-1 degC-1] + real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] + real, dimension(1) :: drdsdp ! The second derivative of density with salinity and + ! pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(1) :: drdtdp ! The second derivative of density with temperature and + ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + T0(1) = T + S0(1) = S + P0(1) = P + call calculate_density_second_derivs_array_NEMO(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + drho_ds_ds = drdsds(1) + drho_ds_dt = drdsdt(1) + drho_dt_dt = drdtdt(1) + drho_ds_dp = drdsdp(1) + drho_dt_dp = drdtdp(1) + +end subroutine calculate_density_second_derivs_scalar_NEMO + +!> \namespace mom_eos_NEMO +!! +!! \section section_EOS_NEMO NEMO equation of state +!! +!! Fabien Roquet and colleagues developed this equation of state using a simple polynomial fit +!! to the TEOS-10 equation of state, for efficiency when used in the NEMO ocean model. Fabien +!! Roquet also graciously provided the MOM6 team with the original code implementing this +!! equation of state, although it has since been modified and extended to have capabilities +!! mirroring those available with other equations of state in MOM6. This particular equation +!! of state is a balance between an accuracy that matches the TEOS-10 density to better than +!! observational uncertainty with a polynomial form that can be evaluated quickly despite having +!! 52 terms. +!! +!! The NEMO label used to describe this equation of state reflects that it was used in the NEMO +!! ocean model before it was used in MOM6, but it probably should be described as the Roquet +!! equation of. However, these algorithms, especially as modified here, are not from +!! the standard NEMO codebase. +!! +!! \subsection section_EOS_NEMO_references References +!! +!! Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015: +!! Accurate polynomial expressions for the density and specific volume +!! of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. + end module MOM_EOS_NEMO From 419085d68ddfd584738050e581f6f8e650a2319f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Feb 2023 08:19:22 -0500 Subject: [PATCH 51/91] +Add calculate_density_second_derivs_UNESCO Added the new public interface calculate_density_second_derivs_UNESCO, which is an overload for both scalar and array versions, to calculate the second derivatives of density with various combinations of temperature, salinity and pressure. Also added a doxygen block at the end of MOM_EOS_UNESCO.F90 to describe this module and the papers it draws upon. Also replaced fatal errors in MOM_EOS with calls to these new routines. All answers are bitwise identical, but there are newly permitted combinations of options that previously failed. --- src/equation_of_state/MOM_EOS.F90 | 29 +-- src/equation_of_state/MOM_EOS_UNESCO.F90 | 224 +++++++++++++++++++++-- 2 files changed, 226 insertions(+), 27 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index db60214373..179f67ec43 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -25,6 +25,7 @@ module MOM_EOS use MOM_EOS_Wright_red, only : calculate_density_second_derivs_wright_red use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco +use MOM_EOS_UNESCO, only : calculate_density_second_derivs_UNESCO use MOM_EOS_UNESCO, only : calculate_compress_unesco use MOM_EOS_NEMO, only : calculate_density_nemo use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo @@ -265,8 +266,8 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r call calculate_density_second_derivs_wright_red(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case (EOS_UNESCO) - call MOM_error(FATAL, "calculate_stanley_density_scalar: "//& - "EOS_UNESCO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_UNESCO(T_scale*T, S_scale*S, p_scale*pressure, & + d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case (EOS_NEMO) call calculate_density_second_derivs_NEMO(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) @@ -374,8 +375,9 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh call calculate_density_second_derivs_wright_red(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) case (EOS_UNESCO) - call MOM_error(FATAL, "calculate_stanley_density_array: "//& - "EOS_UNESCO is not set up to calculate second derivatives yet.") + call calculate_density_UNESCO(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_UNESCO(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) case (EOS_NEMO) call calculate_density_NEMO(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_NEMO(T, S, pressure, d2RdSS, d2RdST, & @@ -528,8 +530,9 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, call calculate_density_second_derivs_wright_red(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) case (EOS_UNESCO) - call MOM_error(FATAL, "calculate_stanley_density_1d: "//& - "EOS_UNESCO is not set up to calculate second derivatives yet.") + call calculate_density_UNESCO(Ta, Sa, pres, rho, is, npts, rho_reference) + call calculate_density_second_derivs_UNESCO(Ta, Sa, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, is, npts) case (EOS_NEMO) call calculate_density_NEMO(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_NEMO(Ta, Sa, pres, d2RdSS, d2RdST, & @@ -1052,8 +1055,8 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d call calculate_density_second_derivs_wright_red(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_UNESCO) - call MOM_error(FATAL, "calculate_density_second_derivs: "//& - "EOS_UNESCO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_UNESCO(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_NEMO) call calculate_density_second_derivs_NEMO(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1083,8 +1086,8 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d call calculate_density_second_derivs_wright_red(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_UNESCO) - call MOM_error(FATAL, "calculate_density_second_derivs: "//& - "EOS_UNESCO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_UNESCO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_NEMO) call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1168,8 +1171,8 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr call calculate_density_second_derivs_wright_red(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_UNESCO) - call MOM_error(FATAL, "calculate_density_second_derivs: "//& - "EOS_UNESCO is not set up to calculate second derivatives yet.") + call calculate_density_second_derivs_UNESCO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_NEMO) call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) @@ -1985,7 +1988,7 @@ logical function EOS_unit_tests(verbose) EOS_unit_tests = .false. ! Normally return false call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_UNESCO) - fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "UNESCO", skip_2nd=.true., & + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "UNESCO", & rho_check=1027.5434579611974*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "UNESCO EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index 59ebb92c7a..1c445e3453 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -3,18 +3,12 @@ module MOM_EOS_UNESCO ! This file is part of MOM6. See LICENSE.md for the license. -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the fit to the UNESCO equation of state given by * -!* the expressions from Jackett and McDougall, 1995, J. Atmos. * -!* Ocean. Tech., 12, 381-389. Coded by J. Stephens, 9/99. * -!*********************************************************************** - implicit none ; private public calculate_compress_UNESCO, calculate_density_UNESCO, calculate_spec_vol_UNESCO public calculate_density_derivs_UNESCO public calculate_density_scalar_UNESCO, calculate_density_array_UNESCO +public calculate_density_second_derivs_UNESCO !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity [PSU], potential temperature [degC] and pressure [Pa], @@ -30,6 +24,13 @@ module MOM_EOS_UNESCO module procedure calculate_spec_vol_scalar_UNESCO, calculate_spec_vol_array_UNESCO end interface calculate_spec_vol_UNESCO +!> Compute the second derivatives of density with various combinations of temperature, salinity and +!! pressure, using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +interface calculate_density_second_derivs_UNESCO + module procedure calculate_density_second_derivs_scalar_UNESCO, calculate_density_second_derivs_array_UNESCO +end interface calculate_density_second_derivs_UNESCO + + !>@{ Parameters in the UNESCO equation of state, as published in appendix A3 of Gill, 1982. ! The following constants are used to calculate rho0, the density of seawater at 1 ! atmosphere pressure. The notation is Rab for the contribution to rho0 from T^a*S^b. @@ -45,15 +46,15 @@ module MOM_EOS_UNESCO real, parameter :: R31 = -8.2467e-7 ! A coefficient in the fit for rho0 [kg m-3 degC-3 PSU-1] real, parameter :: R41 = 5.3875e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-4 PSU-1] real, parameter :: R032 = -5.72466e-3 ! A coefficient in the fit for rho0 [kg m-3 PSU-3/2] -real, parameter :: R132 = 1.0227e-4 ! A coefficient in the fit for rho0 [kg m-3 PSU-3/2] -real, parameter :: R232 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 PSU-3/2] +real, parameter :: R132 = 1.0227e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-3/2] +real, parameter :: R232 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-3/2] real, parameter :: R02 = 4.8314e-4 ! A coefficient in the fit for rho0 [kg m-3 PSU-2] ! The following constants are used to calculate the secant bulk modulus. ! The notation here is Sab for terms proportional to T^a*S^b, ! Spab for terms proportional to p*T^a*S^b, and SP0ab for terms ! proportional to p^2*T^a*S^b. -! Note that these values differ from those in Appendix A of Gill (1982) because the expressions +! Note that these values differ from those in Appendix 3 of Gill (1982) because the expressions ! from Jackett and MacDougall (1995) use potential temperature, rather than in situ temperature. real, parameter :: S00 = 1.965933e4 ! A coefficient in the secant bulk modulus fit [bar] real, parameter :: S10 = 1.444304e2 ! A coefficient in the secant bulk modulus fit [bar degC-1] @@ -357,10 +358,9 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) real :: rho0 ! Density at 1 bar pressure [kg m-3]. real :: ks ! The secant bulk modulus [bar]. real :: ks_0 ! The secant bulk modulus at zero pressure [bar]. - real :: ks_1 ! The derivative of the secant bulk modulus with pressure at zero pressure [nondim]. - real :: ks_2 ! The second derivative of the secant bulk modulus with pressure at zero pressure [nondim]. - real :: dks_dp ! The derivative of the secant bulk modulus - ! with pressure [nondim] + real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] + real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] + real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] integer :: j do j=start,start+npts-1 @@ -395,5 +395,201 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) enddo end subroutine calculate_compress_UNESCO +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +subroutine calculate_density_second_derivs_array_UNESCO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] + real, dimension(:), intent(in ) :: S !< Salinity [PSU] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: I_s12 ! The inverse of the square root of salinity [PSU-1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: d2rho0_dS2 ! Second derivative of rho0 with salinity [kg m-3 PSU-1] + real :: d2rho0_dSdT ! Second derivative of rho0 with temperature and salinity [kg m-3 degC-1 PSU-1] + real :: d2rho0_dT2 ! Second derivative of rho0 with temperature [kg m-3 degC-2] + real :: ks ! The secant bulk modulus [bar] + real :: ks_0 ! The secant bulk modulus at zero pressure [bar] + real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] + real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] + real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] + real :: dks_dT ! Derivative of the secant bulk modulus with temperature [bar degC-1] + real :: dks_dS ! Derivative of the secant bulk modulus with salinity [bar psu-1] + real :: d2ks_dT2 ! Second derivative of the secant bulk modulus with temperature [bar degC-2] + real :: d2ks_dSdT ! Second derivative of the secant bulk modulus with salinity and temperature [bar psu-1 degC-1] + real :: d2ks_dS2 ! Second derivative of the secant bulk modulus with salinity [bar psu-2] + real :: d2ks_dSdp ! Second derivative of the secant bulk modulus with salinity and pressure [psu-1] + real :: d2ks_dTdp ! Second derivative of the secant bulk modulus with temperature and pressure [degC-1] + real :: I_denom ! The inverse of the denominator of the expression for density [bar-1] + integer :: j + + do j=start,start+npts-1 + + p1 = P(j)*1.0e-5 ; t1 = T(j) + s1 = max(S(j), 0.0) ; s12 = sqrt(s1) + ! The UNESCO equation of state is a fit to density, but it chooses a form that exhibits a + ! singularity in the second derivatives with salinity for fresh water. To avoid this, the + ! square root of salinity can be treated with a floor such that the contribution from the + ! S**1.5 terms to both the surface density and the secant bulk modulus are lost to roundoff. + ! This salinity is given by (~1e-16*S00/S032)**(2/3) ~= 3e-8 PSU, or S12 ~= 1.7e-4 + I_s12 = 1.0 / (max(s12, 1.0e-4)) + + ! Calculate the density at sea level pressure and its derivatives + rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & + s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & + (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) + drho0_dT = R10 + ( t1*(2.0*R20 + t1*(3.0*R30 + t1*(4.0*R40 + 5.0*R50*t1))) + & + s1*(R11 + ( t1*(2.0*R21 + t1*(3.0*R31 + 4.0*R41*t1)) + & + s12*(R132 + 2.0*R232*t1) ) ) ) + drho0_dS = R01 + ( t1*(R11 + t1*(R21 + t1*(R31 + R41*t1))) + & + (1.5*s12*(R032 + t1*(R132 + R232*t1)) + 2.0*R02*s1) ) + d2rho0_dS2 = 0.75*(R032 + t1*(R132 + R232*t1))*I_s12 + 2.0*R02 + d2rho0_dSdT = R11 + ( t1*(2.*R21 + t1*(3.*R31 + 4.*R41*t1)) + 1.5*s12*(R132 + 2.*R232*t1) ) + d2rho0_dT2 = 2.0*R20 + ( t1*(6.0*R30 + t1*(12.0*R40 + 20.0*R50*t1)) + & + s1*((2.0*R21 + t1*(6.0*R31 + 12.0*R41*t1)) + 2.0*R232*s12) ) + + ! Calculate the secant bulk modulus and its derivatives + ks_0 = S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & + s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) ) + ks_1 = Sp00 + ( t1*(Sp10 + t1*(Sp20 + Sp30*t1)) + & + s1*((Sp01 + t1*(Sp11 + Sp21*t1)) + Sp032*s12) ) + ks_2 = SP000 + ( t1*(SP010 + SP020*t1) + s1*(SP001 + t1*(SP011 + SP021*t1)) ) + + ks = ks_0 + p1*(ks_1 + p1*ks_2) + dks_dp = ks_1 + 2.0*p1*ks_2 + dks_dT = (S10 + ( t1*(2.0*S20 + t1*(3.0*S30 + t1*4.0*S40)) + & + s1*((S11 + t1*(2.0*S21 + 3.0*S31*t1)) + s12*(S132 + 2.0*S232*t1)) )) + & + p1*((Sp10 + t1*(2.0*Sp20 + 3.0*Sp30*t1) + s1*(Sp11 + 2.0*Sp21*t1)) + & + p1*(SP010 + 2.0*SP020*t1 + s1*(SP011 + 2.0*SP021*t1))) + dks_dS = (S01 + ( t1*(S11 + t1*(S21 + S31*t1)) + 1.5*s12*(S032 + t1*(S132 + S232*t1)) )) + & + p1*((Sp01 + t1*(Sp11 + Sp21*t1) + 1.5*Sp032*s12) + & + p1*(SP001 + t1*(SP011 + SP021*t1))) + d2ks_dS2 = 0.75*((S032 + t1*(S132 + S232*t1)) + p1*Sp032)*I_s12 + d2ks_dSdT = (S11 + ( t1*(2.*S21 + 3.*S31*t1) + 1.5*s12*(S132 + 2.*S232*t1) )) + & + p1*((Sp11 + 2.*Sp21*t1) + p1*(SP011 + 2.0*SP021*t1)) + d2ks_dT2 = 2.0*(S20 + ( t1*(3.0*S30 + 6.0*S40*t1) + s1*((S21 + 3.0*S31*t1) + S232*s12) )) + & + 2.0*p1*((Sp20 + (3.0*Sp30*t1 + Sp21*s1)) + p1*(SP020 + SP021*s1)) + + d2ks_dSdp = (Sp01 + (t1*(Sp11 + Sp21*t1) + 1.5*Sp032*s12)) + & + 2.*p1*(SP001 + t1*(SP011 + SP021*t1)) + d2ks_dTdp = (Sp10 + (t1*(2.0*Sp20 + 3.0*Sp30*t1) + s1*(Sp11 + 2.0*Sp21*t1))) + & + 2.*p1*(SP010 + 2.0*SP020*t1 + s1*(SP011 + 2.0*SP021*t1)) + I_denom = 1.0 / (ks - p1) + + ! Expressions for density and its first derivatives are copied here for reference: + ! rho = rho0*ks * I_denom + ! drho_dT = I_denom*(ks*drho0_dT - p1*rho0*I_denom*dks_dT) + ! drho_dS = I_denom*(ks*drho0_dS - p1*rho0*I_denom*dks_dS) + ! drho_dp = 1.0e-5 * (rho0 * I_denom**2) * (ks - dks_dp*p1) + + ! Finally calculate the second derivatives + drho_dS_dS(j) = I_denom * ( ks*d2rho0_dS2 - (p1*I_denom) * & + (2.0*drho0_dS*dks_dS + rho0*(d2ks_dS2 - 2.0*dks_dS**2*I_denom)) ) + drho_dS_dT(j) = I_denom * (ks * d2rho0_dSdT - (p1*I_denom) * & + ((drho0_dT*dks_dS + drho0_dS*dks_dT) + & + rho0*(d2ks_dSdT - 2.0*(dks_dS*dks_dT)*I_denom)) ) + drho_dT_dT(j) = I_denom * ( ks*d2rho0_dT2 - (p1*I_denom) * & + (2.0*drho0_dT*dks_dT + rho0*(d2ks_dT2 - 2.0*dks_dT**2*I_denom)) ) + + ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. + drho_dS_dp(j) = (1.0e-5 * I_denom**2) * ( (ks*drho0_dS - rho0*dks_dS) - & + p1*( (dks_dp*drho0_dS + rho0*d2ks_dSdp) - & + 2.0*(rho0*dks_dS) * ((dks_dp - 1.0)*I_denom) ) ) + drho_dT_dp(j) = (1.0e-5 * I_denom**2) * ( (ks*drho0_dT - rho0*dks_dT) - & + p1*( (dks_dp*drho0_dT + rho0*d2ks_dTdp) - & + 2.0*(rho0*dks_dT) * ((dks_dp - 1.0)*I_denom) ) ) + enddo + +end subroutine calculate_density_second_derivs_array_UNESCO + +!> Second derivatives of density with respect to temperature, salinity and pressure for scalar inputs. +!! Inputs are promoted to 1-element arrays and outputs are demoted to scalars. +subroutine calculate_density_second_derivs_scalar_UNESCO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Potential temperature referenced to 0 dbar + real, intent(in ) :: S !< Salinity [PSU] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 PSU-2] + real, dimension(1) :: drdsdt ! The second derivative of density with salinity and + ! temperature [kg m-3 PSU-1 degC-1] + real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] + real, dimension(1) :: drdsdp ! The second derivative of density with salinity and + ! pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(1) :: drdtdp ! The second derivative of density with temperature and + ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + T0(1) = T + S0(1) = S + P0(1) = P + call calculate_density_second_derivs_array_UNESCO(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + drho_ds_ds = drdsds(1) + drho_ds_dt = drdsdt(1) + drho_dt_dt = drdtdt(1) + drho_ds_dp = drdsdp(1) + drho_dt_dp = drdtdp(1) + +end subroutine calculate_density_second_derivs_scalar_UNESCO + +!> \namespace mom_eos_UNESCO +!! +!! \section section_EOS_UNESCO UNESCO (Jackett & McDougall) equation of state +!! +!! The UNESCO (1981) equation of state is an interationally defined standard fit valid over the +!! range of pressures up to 10000 dbar, tempertures between the freezing point and 40 degC, and +!! salinities between 0 and 42 PSU. Unfortunately, these expressions used in situ temperatures, +!! whereas ocean models (including MOM6) effectively use potential temperatures as their state +!! variables. To avoid needing multiple conversions, Jackett and McDougall (1995) refit the +!! UNESCO equation of state to take potential temperature as a state variable, over the same +!! valid range and funtional form as the original UNESCO expressions. It is this refit from +!! Jackett and McDougall (1995) that is coded up in this module. +!! +!! The functional form of the equation of state includes terms proportional to salinity to the +!! 3/2 power. This introduces a singularity in the second derivative of density with salinity +!! at a salinity of 0, but this has been addressed here by setting a floor of 1e-8 PSU on the +!! salinity that is used in the denominator of these second derivative expressions. This value +!! was chosen to imply a contribution that is smaller than numerical roundoff in the expression +!! for density, which is the field for which the UNESCO equation of state was originally derived. +!! +!! Originally coded in 1999 by J. Stephens. +!! +!! \subsection section_EOS_UNESCO_references References +!! +!! Jackett, D. and T. McDougall, 1995: J. Atmos. Ocean. Tech., 12, 381-389. +!! +!! UNESCO, 1981: Tenth report of the joint panel on oceanographic tables and standards. +!! UNESCO Technical Palers in Maricen Sci. No. 36, UNESCO, Paris. end module MOM_EOS_UNESCO From b4be5967bf9315545d96211ac0a47be71e7247be Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Feb 2023 12:47:09 -0500 Subject: [PATCH 52/91] (*)+Added calc_density_second_derivs_wright_buggy Added the new public interface calc_density_second_derivs_wright_buggy to reproduce the existing answers and corrected bugs in the calculation of the second derivatives of density with temperature and with temperature and pressure in in calculate_density_second_derivs_wright. Also added the new runtime parameter USE_WRIGHT_2ND_DERIV_BUG to indicate that the older (buggy) version of calculate_density_second_derivs_wright is to be used. Most configurations will not be impacted, but by default answers will change with configurations that use the Wright equation of state and one of the Stanley or similar nonlinear EOS parameterizations, unless USE_WRIGHT_2ND_DERIV_BUG is explicitly set to True. This commit also activates the self-consistency unit testing with the Wright equation of state (now that it passes) and limited unit testing of the TEOS-10 equation of state, omitting the second derivative calculations, one of which is failing (the second derivative of density with salinity and pressure) due to a bug in the TEOS10/gsw code. Also added a unit test for consistency of the density and specific volume when an offset reference value is used. --- src/equation_of_state/MOM_EOS.F90 | 115 ++++++++++++++---- src/equation_of_state/MOM_EOS_Wright.F90 | 143 ++++++++++++++++++++--- 2 files changed, 221 insertions(+), 37 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 179f67ec43..0932758432 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -12,7 +12,7 @@ module MOM_EOS use MOM_EOS_Wright, only : calculate_density_derivs_wright use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright -use MOM_EOS_Wright, only : calculate_density_second_derivs_wright +use MOM_EOS_Wright, only : calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy use MOM_EOS_Wright_full, only : calculate_density_wright_full, calculate_spec_vol_wright_full use MOM_EOS_Wright_full, only : calculate_density_derivs_wright_full use MOM_EOS_Wright_full, only : calculate_specvol_derivs_wright_full, int_density_dz_wright_full @@ -139,6 +139,11 @@ module MOM_EOS real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1] real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1] + logical :: use_Wright_2nd_deriv_bug = .false. !< If true, use a separate subroutine that + !! retains a buggy version of the calculations of the second + !! derivative of density with temperature and with temperature and + !! pressure. This bug is corrected in the default version. + ! Unit conversion factors (normally used for dimensional testing but could also allow for ! change of units of arguments to functions) real :: m_to_Z = 1. !< A constant that translates distances in meters to the units of depth [Z m-1 ~> 1] @@ -257,8 +262,13 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r call calculate_density_second_derivs_linear(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T_scale*T, S_scale*S, p_scale*pressure, & + if (EOS%use_Wright_2nd_deriv_bug) then + call calc_density_second_derivs_wright_buggy(T_scale*T, S_scale*S, p_scale*pressure, & + d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) + else + call calculate_density_second_derivs_wright(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) + endif case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) @@ -364,8 +374,13 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh d2RdTT, d2RdSp, d2RdTP, start, npts) case (EOS_WRIGHT) call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + if (EOS%use_Wright_2nd_deriv_bug) then + call calc_density_second_derivs_wright_buggy(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) + else + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + endif case (EOS_WRIGHT_FULL) call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_wright_full(T, S, pressure, d2RdSS, d2RdST, & @@ -519,8 +534,13 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, d2RdTT, d2RdSp, d2RdTP, is, npts) case (EOS_WRIGHT) call calculate_density_wright(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_wright(Ta, Sa, pres, d2RdSS, d2RdST, & + if (EOS%use_Wright_2nd_deriv_bug) then + call calc_density_second_derivs_wright_buggy(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) + else + call calculate_density_second_derivs_wright(Ta, Sa, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, is, npts) + endif case (EOS_WRIGHT_FULL) call calculate_density_wright_full(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, d2RdSS, d2RdST, & @@ -1046,8 +1066,13 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + if (EOS%use_Wright_2nd_deriv_bug) then + call calc_density_second_derivs_wright_buggy(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + else + call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + endif case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1077,8 +1102,13 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d call calculate_density_second_derivs_linear(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + if (EOS%use_Wright_2nd_deriv_bug) then + call calc_density_second_derivs_wright_buggy(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + else + call calculate_density_second_derivs_wright(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + endif case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1162,8 +1192,13 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr call calculate_density_second_derivs_linear(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + if (EOS%use_Wright_2nd_deriv_bug) then + call calc_density_second_derivs_wright_buggy(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) + else + call calculate_density_second_derivs_wright(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) + endif case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) @@ -1680,8 +1715,7 @@ subroutine EOS_init(param_file, EOS, US) EOS%Compressible = .false. call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the density at T=0, S=0.", units="kg m-3", & - default=1000.0) + "this is the density at T=0, S=0.", units="kg m-3", default=1000.0) call get_param(param_file, mdl, "DRHO_DT", EOS%dRho_dT, & "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& "this is the partial derivative of density with "//& @@ -1691,6 +1725,12 @@ subroutine EOS_init(param_file, EOS, US) "this is the partial derivative of density with "//& "salinity.", units="kg m-3 PSU-1", default=0.8) endif + if (EOS%form_of_EOS == EOS_WRIGHT) then + call get_param(param_file, mdl, "USE_WRIGHT_2ND_DERIV_BUG", EOS%use_Wright_2nd_deriv_bug, & + "If true, use a bug in the calculation of the second derivatives of density "//& + "with temperature and with temperature and pressure that causes some terms "//& + "to be only 2/3 of what they should be.", default=.false.) + endif EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & (EOS%form_of_EOS == EOS_WRIGHT) .or. & @@ -2006,8 +2046,7 @@ logical function EOS_unit_tests(verbose) EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT) - ! There are known bugs in two of the second derivatives calculated with the WRIGHT EOS. - fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", skip_2nd=.true., & + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & rho_check=1027.5430359634624*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail @@ -2018,12 +2057,15 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - ! The TEOS10 equation of state is not passing some self consistency tests yet. - ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) - ! fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", & - ! rho_check=1027.4235596149185*EOS_tmp%kg_m3_to_R) - ! if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 EOS has failed some self-consistency tests.") - ! EOS_unit_tests = EOS_unit_tests .or. fail + ! The TEOS10 equation of state is not passing the self consistency tests for dho_dS_dp due + ! to a bug (a missing division by the square root of salinity) on line 109 of + ! pkg/GSW-Fortan/toolbox/gsw_specvol_second_derivatives.f90. This bug has been highlighted in an + ! issue posted to the TEOS-10/GSW-Fortran page at github.com/TEOS-10/GSW-Fortran/issues/26. + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", skip_2nd=.true., & + rho_check=1027.4235596149185*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", & @@ -2054,13 +2096,17 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & real, dimension(-3:3,-3:3,-3:3) :: T ! Temperatures at the test value and perturbed points [C ~> degC] real, dimension(-3:3,-3:3,-3:3) :: S ! Salinites at the test value and perturbed points [S ~> ppt] real, dimension(-3:3,-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] - real, dimension(-3:3,-3:3,-3:3,2) :: rho ! Densities at the test value and perturbed points [R ~> kg m-3] - real, dimension(-3:3,-3:3,-3:3,2) :: spv ! Specific volumes at the test value and perturbed points [R-1 ~> m3 kg-1] + real, dimension(-3:3,-3:3,-3:3,2) :: rho ! Densities relative to rho_ref at the test value and + ! perturbed points [R ~> kg m-3] + real, dimension(-3:3,-3:3,-3:3,2) :: spv ! Specific volumes relative to spv_ref at the test value and + ! perturbed points [R-1 ~> m3 kg-1] real :: dT ! Magnitude of temperature perturbations [C ~> degC] real :: dS ! Magnitude of salinity perturbations [S ~> ppt] real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa] real :: rho_ref ! A reference density that is extracted for greater accuracy [R ~> kg m-3] - real :: spv_ref ! A reference specific vlume that is extracted for greater accuracy [R-1 ~> m3 kg-1] + real :: spv_ref ! A reference specific volume that is extracted for greater accuracy [R-1 ~> m3 kg-1] + real :: rho_nooff ! Density with no reference offset [R ~> kg m-3] + real :: spv_nooff ! Specific volume with no reference offset [R-1 ~> m3 kg-1] real :: drho_dT ! The partial derivative of density with potential ! temperature [R C-1 ~> kg m-3 degC-1] real :: drho_dS ! The partial derivative of density with salinity @@ -2109,6 +2155,7 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & real :: count_fac2 ! A factor in the roundoff estimates based on the factors in the numerator and ! denominator in the finite difference second derivative expression [nondim] character(len=200) :: mesg + logical :: test_OK ! True if a particular test is consistent. logical :: OK ! True if all checks so far are consistent. logical :: test_2nd ! If true, do tests on the 2nd derivative calculations integer :: order ! The order of accuracy of the centered finite difference estimates (2, 4 or 6). @@ -2175,7 +2222,6 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & endif else OK = (abs((rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0) < tol) - if (verbose .and. .not.OK) then write(mesg, '(ES16.8," and ",ES16.8,", ratio - 1 = ",ES16.8)') & rho(0,0,0,1), 1.0/(spv_ref + spv(0,0,0,1)) - rho_ref, & @@ -2184,14 +2230,37 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & endif endif if (present(rho_check)) then - OK = OK .and. (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) - if (verbose .and. .not.OK) then + test_OK = (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) + OK = OK .and. test_OK + if (verbose .and. .not.test_OK) then write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & rho_check, rho_ref+rho(0,0,0,1), tol*rho(0,0,0,1) call MOM_error(WARNING, "The value of "//trim(EOS_name)//" rho disagrees with its check value :"//trim(mesg)) endif endif + ! Check that the densities are consistent when the reference value is extracted + call calculate_density(T(0,0,0), S(0,0,0), p(0,0,0), rho_nooff, EOS) + test_OK = (abs(rho_nooff - (rho_ref + rho(0,0,0,1))) < tol*rho_nooff) + OK = OK .and. test_OK + if (verbose .and. .not.test_OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + rho_ref+rho(0,0,0,1), rho_nooff, tol*rho_nooff + call MOM_error(WARNING, "For "//trim(EOS_name)//& + " rho with and without a reference value disagree: "//trim(mesg)) + endif + + ! Check that the specific volumes are consistent when the reference value is extracted + call calculate_spec_vol(T(0,0,0), S(0,0,0), p(0,0,0), spv_nooff, EOS) + test_OK = (abs(spv_nooff - (spv_ref + spv(0,0,0,1))) < tol*rho_nooff) + OK = OK .and. test_OK + if (verbose .and. .not.test_OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + spv_ref + spv(0,0,0,1), spv_nooff, tol*spv_nooff + call MOM_error(WARNING, "For "//trim(EOS_name)//& + " spv with and without a reference value disagree: "//trim(mesg)) + endif + ! Account for the factors of terms in the numerator and denominator when estimating roundoff if (order == 6) then count_fac = 110.0/60.0 ; count_fac2 = 1088.0/180.0 diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 5fd67dcfb3..ba73319423 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -11,12 +11,12 @@ module MOM_EOS_Wright public calculate_compress_wright, calculate_density_wright, calculate_spec_vol_wright public calculate_density_derivs_wright, calculate_specvol_derivs_wright -public calculate_density_second_derivs_wright +public calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy public int_density_dz_wright, int_spec_vol_dp_wright !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity in practical salinity units ([PSU]), potential -!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! temperature (in degrees Celsius [degC]) and pressure [Pa], using the expressions from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. interface calculate_density_wright module procedure calculate_density_scalar_wright, calculate_density_array_wright @@ -24,7 +24,7 @@ module MOM_EOS_Wright !> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect !! to a reference specific volume, from salinity in practical salinity units ([PSU]), potential -!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! temperature (in degrees Celsius [degC]) and pressure [Pa], using the expressions from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. interface calculate_spec_vol_wright module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright @@ -36,11 +36,19 @@ module MOM_EOS_Wright end interface calculate_density_derivs_wright !> Compute the second derivatives of density with various combinations -!! of temperature, salinity, and pressure +!! of temperature, salinity and pressure, using the expressions from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. interface calculate_density_second_derivs_wright module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright end interface calculate_density_second_derivs_wright +!> Compute the second derivatives of density with various combinations of temperature, salinity and +!! pressure, but deliberately retaining a bug that reproduces older answers for the second +!! derivative of density with temperature and the second derivative with temperature and pressure +interface calc_density_second_derivs_wright_buggy + module procedure calc_dens_second_derivs_buggy_scalar_wright, calc_dens_second_derivs_buggy_array_wright +end interface calc_density_second_derivs_wright_buggy + !>@{ Parameters in the Wright equation of state using the reduced range formula, which is a fit to the UNESCO ! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. @@ -69,7 +77,7 @@ module MOM_EOS_Wright !> Computes the in situ density of sea water for scalar inputs and outputs. !! !! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), -!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) real, intent(in) :: T !< Potential temperature relative to the surface [degC]. @@ -96,7 +104,7 @@ end subroutine calculate_density_scalar_wright !> Computes the in situ density of sea water for 1-d array inputs and outputs. !! !! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), -!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740 with the reduced range fit coefficients. subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. @@ -263,7 +271,7 @@ subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_ end subroutine calculate_density_derivs_scalar_wright -!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. +!> Second derivatives of density with respect to temperature, salinity and pressure for 1-d array inputs and outputs. subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp, start, npts) real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] @@ -282,6 +290,112 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh integer, intent(in ) :: start !< Starting index in T,S,P integer, intent(in ) :: npts !< Number of points to loop over + ! Local variables + real :: z0, z1 ! Local work variables [Pa] + real :: z2, z4 ! Local work variables [m2 s-2] + real :: z3, z5 ! Local work variables [Pa degC-1] + real :: z6, z8 ! Local work variables [m2 s-2 degC-1] + real :: z7 ! A local work variable [m2 s-2 PSU-1] + real :: z9 ! A local work variable [m3 kg-1] + real :: z10 ! A local work variable [Pa PSU-1] + real :: z11 ! A local work variable [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: z2_2 ! A local work variable [m4 s-4] + real :: z2_3 ! A local work variable [m6 s-6] + integer :: j + ! See the counterpart in MOM_EOS_Wright_full.F90 for a more numerically stable + ! and/or efficient, but mathematically equivalent expression + + do j = start,start+npts-1 + z0 = T(j)*(b1 + b5*S(j) + T(j)*(b2 + b3*T(j))) + z1 = (b0 + P(j) + b4*S(j) + z0) + z3 = (b1 + b5*S(j) + T(j)*(2.*b2 + 3.*b3*T(j))) + z4 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j)))) + z5 = (b1 + b5*S(j) + T(j)*(b2 + b3*T(j)) + T(j)*(b2 + 2.*b3*T(j))) + z6 = c1 + c5*S(j) + T(j)*(c2 + c3*T(j)) + T(j)*(c2 + 2.*c3*T(j)) + z7 = (c4 + c5*T(j) + a2*z1) + z8 = (c1 + c5*S(j) + T(j)*(2.*c2 + 3.*c3*T(j)) + a1*z1) + z9 = (a0 + a2*S(j) + a1*T(j)) + z10 = (b4 + b5*T(j)) + z11 = (z10*z4 - z1*z7) + z2 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j))) + z9*z1) + z2_2 = z2*z2 + z2_3 = z2_2*z2 + + drho_ds_ds(j) = (z10*(c4 + c5*T(j)) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T(j) + z9*z10 + a2*z1)*z11)/z2_3 + drho_ds_dt(j) = (z10*z6 - z1*(c5 + a2*z5) + b5*z4 - z5*z7)/z2_2 - (2.*(z6 + z9*z5 + a1*z1)*z11)/z2_3 + drho_dt_dt(j) = (z3*z6 - z1*(2.*c2 + 6.*c3*T(j) + a1*z5) + (2.*b2 + 6.*b3*T(j))*z4 - z5*z8)/z2_2 - & + (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 + drho_ds_dp(j) = (-c4 - c5*T(j) - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 + drho_dt_dp(j) = (-c1 - c5*S(j) - T(j)*(2.*c2 + 3.*c3*T(j)) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 + enddo + +end subroutine calculate_density_second_derivs_array_wright + +!> Second derivatives of density with respect to temperature, salinity and pressure for scalar inputs. +!! +!! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar +subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Potential temperature referenced to 0 dbar + real, intent(in ) :: S !< Salinity [PSU] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 PSU-2] + real, dimension(1) :: drdsdt ! The second derivative of density with salinity and + ! temperature [kg m-3 PSU-1 degC-1] + real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] + real, dimension(1) :: drdsdp ! The second derivative of density with salinity and + ! pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(1) :: drdtdp ! The second derivative of density with temperature and + ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + T0(1) = T + S0(1) = S + P0(1) = P + call calculate_density_second_derivs_array_wright(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + drho_ds_ds = drdsds(1) + drho_ds_dt = drdsdt(1) + drho_dt_dt = drdtdt(1) + drho_ds_dp = drdsdp(1) + drho_dt_dp = drdtdp(1) + +end subroutine calculate_density_second_derivs_scalar_wright + +!> Second derivatives of density with respect to temperature, salinity and pressure for 1-d array +!! inputs and outputs, but deliberately including a bug to reproduce previous answers, in which +!! some terms in the expressions for drho_dt_dt and drho_dt_dp are 2/3 of what they should be. +subroutine calc_dens_second_derivs_buggy_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] + real, dimension(:), intent(in ) :: S !< Salinity [PSU] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + ! Local variables real :: z0, z1 ! Local work variables [Pa] real :: z2, z4 ! Local work variables [m2 s-2] @@ -322,13 +436,14 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh drho_dt_dp(j) = (-c1 - c5*S(j) - T(j)*(2.*c2 + 3.*c3*T(j)) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 enddo -end subroutine calculate_density_second_derivs_array_wright +end subroutine calc_dens_second_derivs_buggy_array_wright -!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. +!> Second derivatives of density with respect to temperature, salinity and pressure for scalar +!! inputs, but deliberately including a bug to reproduce previous answers. !! !! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array !! and then demotes the output back to a scalar -subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & +subroutine calc_dens_second_derivs_buggy_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp) real, intent(in ) :: T !< Potential temperature referenced to 0 dbar real, intent(in ) :: S !< Salinity [PSU] @@ -366,7 +481,7 @@ subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, dr drho_ds_dp = drdsdp(1) drho_dt_dp = drdtdp(1) -end subroutine calculate_density_second_derivs_scalar_wright +end subroutine calc_dens_second_derivs_buggy_scalar_wright !> Return the partial derivatives of specific volume with temperature and salinity !! for 1-d array inputs and outputs @@ -872,7 +987,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - ! T, S, and p are interpolated in the horizontal. The p interpolation + ! T, S and p are interpolated in the horizontal. The p interpolation ! is linear, but for T and S it may be thickness weighted. al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) @@ -913,7 +1028,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - ! T, S, and p are interpolated in the horizontal. The p interpolation + ! T, S and p are interpolated in the horizontal. The p interpolation ! is linear, but for T and S it may be thickness weighted. al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) @@ -937,7 +1052,7 @@ end subroutine int_spec_vol_dp_wright !! \section section_EOS_Wright Wright equation of state !! !! Wright, 1997, provide an approximation for the in situ density as a function of -!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! potential temperature, salinity and pressure. The formula follow the Tumlirz !! equation of state which are easier to evaluate and make efficient. !! !! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this From 332b7e37e1b9b482b68e33fdaf372669f07b90a4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 4 Mar 2023 08:50:34 -0500 Subject: [PATCH 53/91] *Refactor MOM_EOS_UNESCO.F90 Refactored the expressions in MOM_EOS_UNESCO.F90, adding parentheses to specify the order of arithmetic, starting with the highest-order terms first for less sensitivity to round-off. Also added comments to better describe the references for these algorithms. Although the revised expressions are all mathematically equivalent, this commit will change answers for any cases that use EQN_OF_STATE = "UNESCO". However, it is believed based on a survey of the MOM6 community that there are no active configurations that use this equation of state. --- src/equation_of_state/MOM_EOS_UNESCO.F90 | 402 +++++++++++------------ 1 file changed, 184 insertions(+), 218 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index 1c445e3453..b6398e07e2 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -52,8 +52,7 @@ module MOM_EOS_UNESCO ! The following constants are used to calculate the secant bulk modulus. ! The notation here is Sab for terms proportional to T^a*S^b, -! Spab for terms proportional to p*T^a*S^b, and SP0ab for terms -! proportional to p^2*T^a*S^b. +! SpABC for terms proportional to p^A*T^B*S^C. ! Note that these values differ from those in Appendix 3 of Gill (1982) because the expressions ! from Jackett and MacDougall (1995) use potential temperature, rather than in situ temperature. real, parameter :: S00 = 1.965933e4 ! A coefficient in the secant bulk modulus fit [bar] @@ -69,21 +68,21 @@ module MOM_EOS_UNESCO real, parameter :: S132 = 9.085835e-3 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-3/2] real, parameter :: S232 = -4.619924e-4 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-3/2] -real, parameter :: Sp00 = 3.186519 ! A coefficient in the secant bulk modulus fit [nondim] -real, parameter :: Sp10 = 2.212276e-2 ! A coefficient in the secant bulk modulus fit [degC-1] -real, parameter :: Sp20 = -2.984642e-4 ! A coefficient in the secant bulk modulus fit [degC-2] -real, parameter :: Sp30 = 1.956415e-6 ! A coefficient in the secant bulk modulus fit [degC-3] -real, parameter :: Sp01 = 6.704388e-3 ! A coefficient in the secant bulk modulus fit [PSU-1] -real, parameter :: Sp11 = -1.847318e-4 ! A coefficient in the secant bulk modulus fit [degC-1 PSU-1] -real, parameter :: Sp21 = 2.059331e-7 ! A coefficient in the secant bulk modulus fit [degC-2 PSU-1] -real, parameter :: Sp032 = 1.480266e-4 ! A coefficient in the secant bulk modulus fit [PSU-3/2] - -real, parameter :: SP000 = 2.102898e-4 ! A coefficient in the secant bulk modulus fit [bar-1] -real, parameter :: SP010 = -1.202016e-5 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1] -real, parameter :: SP020 = 1.394680e-7 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2] -real, parameter :: SP001 = -2.040237e-6 ! A coefficient in the secant bulk modulus fit [bar-1 PSU-1] -real, parameter :: SP011 = 6.128773e-8 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-1] -real, parameter :: SP021 = 6.207323e-10 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-2] +real, parameter :: Sp100 = 3.186519 ! A coefficient in the secant bulk modulus fit [nondim] +real, parameter :: Sp110 = 2.212276e-2 ! A coefficient in the secant bulk modulus fit [degC-1] +real, parameter :: Sp120 = -2.984642e-4 ! A coefficient in the secant bulk modulus fit [degC-2] +real, parameter :: Sp130 = 1.956415e-6 ! A coefficient in the secant bulk modulus fit [degC-3] +real, parameter :: Sp101 = 6.704388e-3 ! A coefficient in the secant bulk modulus fit [PSU-1] +real, parameter :: Sp111 = -1.847318e-4 ! A coefficient in the secant bulk modulus fit [degC-1 PSU-1] +real, parameter :: Sp121 = 2.059331e-7 ! A coefficient in the secant bulk modulus fit [degC-2 PSU-1] +real, parameter :: Sp1032 = 1.480266e-4 ! A coefficient in the secant bulk modulus fit [PSU-3/2] + +real, parameter :: Sp200 = 2.102898e-4 ! A coefficient in the secant bulk modulus fit [bar-1] +real, parameter :: Sp210 = -1.202016e-5 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1] +real, parameter :: Sp220 = 1.394680e-7 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2] +real, parameter :: Sp201 = -2.040237e-6 ! A coefficient in the secant bulk modulus fit [bar-1 PSU-1] +real, parameter :: Sp211 = 6.128773e-8 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-1] +real, parameter :: Sp221 = 6.207323e-10 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-2] !>@} contains @@ -93,11 +92,11 @@ module MOM_EOS_UNESCO !! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). !! If rho_ref is present, rho is an anomaly from rho_ref. subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: rho !< In situ density [kg m-3]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] @@ -119,51 +118,42 @@ end subroutine calculate_density_scalar_UNESCO !! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). !! If rho_ref is present, rho is an anomaly from rho_ref. subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative 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]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, dimension(:), intent(in) :: T !< Potential temperature relative 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] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] ! Local variables - real :: t_local ! A copy of the temperature at a point [degC] - real :: t2, t3 ! Temperature squared [degC2] and cubed [degC3] - real :: t4, t5 ! Temperature to the 4th power [degC4] and 5th power [degC5] - real :: s_local ! A copy of the salinity at a point [PSU] - real :: s32 ! The square root of salinity cubed [PSU3/2] - real :: s2 ! Salinity squared [PSU2]. - real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: sig0 ! The anomaly of rho0 from R00 [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: sig0 ! The anomaly of rho0 from R00 [kg m-3] + real :: ks ! The secant bulk modulus [bar] integer :: j do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - rho(j) = 1000.0 - cycle - endif - - p1 = pressure(j)*1.0e-5 ; p2 = p1*p1 - t_local = T(j) ; t2 = t_local*t_local ; t3 = t_local*t2 ; t4 = t2*t2 ; t5 = t3*t2 - s_local = S(j) ; s2 = s_local*s_local ; s32 = s_local*sqrt(s_local) + p1 = pressure(j)*1.0e-5 ; t1 = T(j) + s1 = max(S(j), 0.0) ; s12 = sqrt(s1) ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). - sig0 = R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 + sig0 = ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & + s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & + (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) rho0 = R00 + sig0 ! Compute rho(s,theta,p), first calculating the secant bulk modulus. - ks = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + & - s32*(S032 + S132*t_local + S232*t2) + & - p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) + ks = (S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & + s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) )) + & + p1*( (Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & + s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) )) + & + p1*(Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) )) ) if (present(rho_ref)) then rho(j) = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) @@ -178,12 +168,11 @@ end subroutine calculate_density_array_UNESCO !! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_UNESCO(T, S, pressure, specvol, spv_ref) - real, intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: specvol !< In situ specific volume [m3 kg-1] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] @@ -202,51 +191,41 @@ end subroutine calculate_spec_vol_scalar_UNESCO !! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] ! Local variables - real :: t_local ! A copy of the temperature at a point [degC] - real :: t2, t3 ! Temperature squared [degC2] and cubed [degC3] - real :: t4, t5 ! Temperature to the 4th power [degC4] and 5th power [degC5] - real :: s_local ! A copy of the salinity at a point [PSU] - real :: s32 ! The square root of salinity cubed [PSU3/2] - real :: s2 ! Salinity squared [PSU2]. - real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2]l553 + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] integer :: j do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - specvol(j) = 0.001 - if (present(spv_ref)) specvol(j) = 0.001 - spv_ref - cycle - endif - p1 = pressure(j)*1.0e-5 ; p2 = p1*p1 - t_local = T(j) ; t2 = t_local*t_local ; t3 = t_local*t2 ; t4 = t2*t2 ; t5 = t3*t2 - s_local = S(j) ; s2 = s_local*s_local ; s32 = s_local*sqrt(s_local) + p1 = pressure(j)*1.0e-5 ; t1 = T(j) + s1 = max(S(j), 0.0) ; s12 = sqrt(s1) -! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). - rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 + rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & + s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & + (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) -! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. - ks = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + & - s32*(S032 + S132*t_local + S232*t2) + & - p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) + ks = (S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & + s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) )) + & + p1*( (Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & + s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) )) + & + p1*(Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) )) ) if (present(spv_ref)) then specvol(j) = (ks*(1.0 - (rho0*spv_ref)) - p1) / (rho0*ks) @@ -257,73 +236,63 @@ subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, end subroutine calculate_spec_vol_array_UNESCO -!> This subroutine calculates the partial derivatives of density -!! with potential temperature and salinity. +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC] + real, intent(in), dimension(:) :: S !< Salinity [PSU] + real, intent(in), dimension(:) :: pressure !< Pressure [Pa] real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. + !! temperature [kg m-3 degC-1] real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 PSU-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + !! in [kg m-3 PSU-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate ! Local variables - real :: t_local ! A copy of the temperature at a point [degC] - real :: t2, t3 ! Temperature squared [degC2] and cubed [degC3] - real :: t4, t5 ! Temperature to the 4th power [degC4] and 5th power [degC5] - real :: s12 ! The square root of salinity [PSU1/2] - real :: s_local ! A copy of the salinity at a point [PSU] - real :: s32 ! The square root of salinity cubed [PSU3/2] - real :: s2 ! Salinity squared [PSU2]. - real :: p1, p2 ! Pressure to the 1st & 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. - real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1]. - real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1]. - real :: dks_dT ! Derivative of ks with T [bar degC-1]. - real :: dks_dS ! Derivative of ks with S [bar psu-1]. - real :: denom ! 1.0 / (ks - p1) [bar-1]. + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: dks_dT ! Derivative of ks with T [bar degC-1] + real :: dks_dS ! Derivative of ks with S [bar psu-1] + real :: denom ! 1.0 / (ks - p1) [bar-1] integer :: j do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - drho_dT(j) = 0.0 ; drho_dS(j) = 0.0 - cycle - endif - p1 = pressure(j)*1.0e-5 ; p2 = p1*p1 - t_local = T(j) ; t2 = t_local*t_local ; t3 = t_local*t2 ; t4 = t2*t2 ; t5 = t3*t2 - s_local = S(j) ; s2 = s_local*s_local ; s12 = sqrt(s_local) ; s32 = s_local*s12 - -! compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ) - - rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 - drho0_dT = R10 + 2.0*R20*t_local + 3.0*R30*t2 + 4.0*R40*t3 + 5.0*R50*t4 + & - s_local*(R11 + 2.0*R21*t_local + 3.0*R31*t2 + 4.0*R41*t3) + & - s32*(R132 + 2.0*R232*t_local) - drho0_dS = (R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - 1.5*s12*(R032 + R132*t_local + R232*t2) + 2.0*R02*s_local - -! compute rho(s,theta,p) - - ks = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + & - s32*(S032 + S132*t_local + S232*t2) + & - p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) - dks_dT = S10 + 2.0*S20*t_local + 3.0*S30*t2 + 4.0*S40*t3 + & - s_local*(S11 + 2.0*S21*t_local + 3.0*S31*t2) + s32*(S132 + 2.0*S232*t_local) + & - p1*(Sp10 + 2.0*Sp20*t_local + 3.0*Sp30*t2 + s_local*(Sp11 + 2.0*Sp21*t_local)) + & - p2*(SP010 + 2.0*SP020*t_local + s_local*(SP011 + 2.0*SP021*t_local)) - dks_dS = (S01 + S11*t_local + S21*t2 + S31*t3) + 1.5*s12*(S032 + S132*t_local + S232*t2) + & - p1*(Sp01 + Sp11*t_local + Sp21*t2 + 1.5*Sp032*s12) + & - p2*(SP001 + SP011*t_local + SP021*t2) + p1 = pressure(j)*1.0e-5 ; t1 = T(j) + s1 = max(S(j), 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + + rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & + s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & + (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) + drho0_dT = R10 + ( t1*(2.0*R20 + t1*(3.0*R30 + t1*(4.0*R40 + 5.0*R50*t1))) + & + s1*(R11 + (t1*(2.0*R21 + t1*(3.0*R31 + 4.0*R41*t1)) + & + s12*(R132 + 2.0*R232*t1))) ) + drho0_dS = R01 + ( t1*(R11 + t1*(R21 + t1*(R31 + R41*t1))) + & + (1.5*s12*(R032 + t1*(R132 + R232*t1)) + 2.0*R02*s1) ) + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + + ks = ( S00 + (t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & + s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1)))) ) + & + p1*( (Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & + s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) )) + & + p1*(Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) )) ) + dks_dT = ( S10 + (t1*(2.0*S20 + t1*(3.0*S30 + t1*4.0*S40)) + & + s1*((S11 + t1*(2.0*S21 + 3.0*S31*t1)) + s12*(S132 + 2.0*S232*t1))) ) + & + p1*((Sp110 + t1*(2.0*Sp120 + 3.0*Sp130*t1) + s1*(Sp111 + 2.0*Sp121*t1)) + & + p1*(Sp210 + 2.0*Sp220*t1 + s1*(Sp211 + 2.0*Sp221*t1))) + dks_dS = ( S01 + (t1*(S11 + t1*(S21 + S31*t1)) + 1.5*s12*(S032 + t1*(S132 + S232*t1))) ) + & + p1*((Sp101 + t1*(Sp111 + Sp121*t1) + 1.5*Sp1032*s12) + & + p1*(Sp201 + t1*(Sp211 + Sp221*t1))) denom = 1.0 / (ks - p1) drho_dT(j) = denom*(ks*drho0_dT - rho0*p1*denom*dks_dT) @@ -332,65 +301,57 @@ subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, sta end subroutine calculate_density_derivs_UNESCO -!> This subroutine computes the in situ density of sea water (rho) -!! and the compressibility (drho/dp == C_sound^-2) at the given -!! salinity, potential temperature, and pressure. +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure using the UNESCO (1981) +!! equation of state, as refit by Jackett and McDougall (1995). subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. - real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. + !! [degC] + real, intent(in), dimension(:) :: S !< Salinity [PSU] + real, intent(in), dimension(:) :: pressure !< Pressure [Pa] + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3] real, intent(out), dimension(:) :: 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 !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + !! [s2 m-2] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate ! Local variables - real :: t_local ! A copy of the temperature at a point [degC] - real :: t2, t3 ! Temperature squared [degC2] and cubed [degC3] - real :: t4, t5 ! Temperature to the 4th power [degC4] and 5th power [degC5] - real :: s_local ! A copy of the salinity at a point [PSU] - real :: s32 ! The square root of salinity cubed [PSU3/2] - real :: s2 ! Salinity squared [PSU2]. - real :: p1, p2 ! Pressure to the 1st & 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. - real :: ks_0 ! The secant bulk modulus at zero pressure [bar]. + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: ks_0 ! The secant bulk modulus at zero pressure [bar] real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] integer :: j do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - rho(j) = 1000.0 ; drho_dP(j) = 0.0 - cycle - endif + p1 = pressure(j)*1.0e-5 ; t1 = T(j) + s1 = max(S(j), 0.0) ; s12 = sqrt(s1) - p1 = pressure(j)*1.0e-5 ; p2 = p1*p1 - t_local = T(j) ; t2 = t_local*t_local ; t3 = t_local*t2 ; t4 = t2*t2 ; t5 = t3*t2 - s_local = S(j) ; s2 = s_local*s_local ; s32 = s_local*sqrt(s_local) + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). -! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). - - rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 + rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & + s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & + (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) -! Compute rho(s,theta,p), first calculating the secant bulk modulus. - ks_0 = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + & - s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + s32*(S032 + S132*t_local + S232*t2) - ks_1 = Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32 - ks_2 = SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2) + ! Calculate the secant bulk modulus and its derivative with pressure. + ks_0 = S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & + s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) ) + ks_1 = Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & + s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) ) + ks_2 = Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) ) - ks = ks_0 + p1*ks_1 + p2*ks_2 + ks = ks_0 + p1*(ks_1 + p1*ks_2) dks_dp = ks_1 + 2.0*p1*ks_2 + ! Compute the in situ density, rho(s,theta,p), and its derivative with pressure. rho(j) = rho0*ks / (ks - p1) -! The factor of 1.0e-5 is because pressure here is in bars, not Pa. + ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. drho_dp(j) = 1.0e-5 * (rho(j) / (ks - p1)) * (1.0 - dks_dp*p1/ks) enddo end subroutine calculate_compress_UNESCO @@ -463,36 +424,36 @@ subroutine calculate_density_second_derivs_array_UNESCO(T, S, P, drho_ds_ds, drh drho0_dS = R01 + ( t1*(R11 + t1*(R21 + t1*(R31 + R41*t1))) + & (1.5*s12*(R032 + t1*(R132 + R232*t1)) + 2.0*R02*s1) ) d2rho0_dS2 = 0.75*(R032 + t1*(R132 + R232*t1))*I_s12 + 2.0*R02 - d2rho0_dSdT = R11 + ( t1*(2.*R21 + t1*(3.*R31 + 4.*R41*t1)) + 1.5*s12*(R132 + 2.*R232*t1) ) + d2rho0_dSdT = R11 + ( t1*(2.0*R21 + t1*(3.0*R31 + 4.0*R41*t1)) + 1.5*s12*(R132 + 2.0*R232*t1) ) d2rho0_dT2 = 2.0*R20 + ( t1*(6.0*R30 + t1*(12.0*R40 + 20.0*R50*t1)) + & s1*((2.0*R21 + t1*(6.0*R31 + 12.0*R41*t1)) + 2.0*R232*s12) ) ! Calculate the secant bulk modulus and its derivatives ks_0 = S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) ) - ks_1 = Sp00 + ( t1*(Sp10 + t1*(Sp20 + Sp30*t1)) + & - s1*((Sp01 + t1*(Sp11 + Sp21*t1)) + Sp032*s12) ) - ks_2 = SP000 + ( t1*(SP010 + SP020*t1) + s1*(SP001 + t1*(SP011 + SP021*t1)) ) + ks_1 = Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & + s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) ) + ks_2 = Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) ) ks = ks_0 + p1*(ks_1 + p1*ks_2) dks_dp = ks_1 + 2.0*p1*ks_2 dks_dT = (S10 + ( t1*(2.0*S20 + t1*(3.0*S30 + t1*4.0*S40)) + & s1*((S11 + t1*(2.0*S21 + 3.0*S31*t1)) + s12*(S132 + 2.0*S232*t1)) )) + & - p1*((Sp10 + t1*(2.0*Sp20 + 3.0*Sp30*t1) + s1*(Sp11 + 2.0*Sp21*t1)) + & - p1*(SP010 + 2.0*SP020*t1 + s1*(SP011 + 2.0*SP021*t1))) + p1*((Sp110 + t1*(2.0*Sp120 + 3.0*Sp130*t1) + s1*(Sp111 + 2.0*Sp121*t1)) + & + p1*(Sp210 + 2.0*Sp220*t1 + s1*(Sp211 + 2.0*Sp221*t1))) dks_dS = (S01 + ( t1*(S11 + t1*(S21 + S31*t1)) + 1.5*s12*(S032 + t1*(S132 + S232*t1)) )) + & - p1*((Sp01 + t1*(Sp11 + Sp21*t1) + 1.5*Sp032*s12) + & - p1*(SP001 + t1*(SP011 + SP021*t1))) - d2ks_dS2 = 0.75*((S032 + t1*(S132 + S232*t1)) + p1*Sp032)*I_s12 - d2ks_dSdT = (S11 + ( t1*(2.*S21 + 3.*S31*t1) + 1.5*s12*(S132 + 2.*S232*t1) )) + & - p1*((Sp11 + 2.*Sp21*t1) + p1*(SP011 + 2.0*SP021*t1)) + p1*((Sp101 + t1*(Sp111 + Sp121*t1) + 1.5*Sp1032*s12) + & + p1*(Sp201 + t1*(Sp211 + Sp221*t1))) + d2ks_dS2 = 0.75*((S032 + t1*(S132 + S232*t1)) + p1*Sp1032)*I_s12 + d2ks_dSdT = (S11 + ( t1*(2.0*S21 + 3.0*S31*t1) + 1.5*s12*(S132 + 2.0*S232*t1) )) + & + p1*((Sp111 + 2.0*Sp121*t1) + p1*(Sp211 + 2.0*Sp221*t1)) d2ks_dT2 = 2.0*(S20 + ( t1*(3.0*S30 + 6.0*S40*t1) + s1*((S21 + 3.0*S31*t1) + S232*s12) )) + & - 2.0*p1*((Sp20 + (3.0*Sp30*t1 + Sp21*s1)) + p1*(SP020 + SP021*s1)) + 2.0*p1*((Sp120 + (3.0*Sp130*t1 + Sp121*s1)) + p1*(Sp220 + Sp221*s1)) - d2ks_dSdp = (Sp01 + (t1*(Sp11 + Sp21*t1) + 1.5*Sp032*s12)) + & - 2.*p1*(SP001 + t1*(SP011 + SP021*t1)) - d2ks_dTdp = (Sp10 + (t1*(2.0*Sp20 + 3.0*Sp30*t1) + s1*(Sp11 + 2.0*Sp21*t1))) + & - 2.*p1*(SP010 + 2.0*SP020*t1 + s1*(SP011 + 2.0*SP021*t1)) + d2ks_dSdp = (Sp101 + (t1*(Sp111 + Sp121*t1) + 1.5*Sp1032*s12)) + & + 2.0*p1*(Sp201 + t1*(Sp211 + Sp221*t1)) + d2ks_dTdp = (Sp110 + (t1*(2.0*Sp120 + 3.0*Sp130*t1) + s1*(Sp111 + 2.0*Sp121*t1))) + & + 2.0*p1*(Sp210 + 2.0*Sp220*t1 + s1*(Sp211 + 2.0*Sp221*t1)) I_denom = 1.0 / (ks - p1) ! Expressions for density and its first derivatives are copied here for reference: @@ -521,13 +482,14 @@ subroutine calculate_density_second_derivs_array_UNESCO(T, S, P, drho_ds_ds, drh end subroutine calculate_density_second_derivs_array_UNESCO -!> Second derivatives of density with respect to temperature, salinity and pressure for scalar inputs. +!> Second derivatives of density with respect to temperature, salinity and pressure for scalar inputs +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). !! Inputs are promoted to 1-element arrays and outputs are demoted to scalars. subroutine calculate_density_second_derivs_scalar_UNESCO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp) real, intent(in ) :: T !< Potential temperature referenced to 0 dbar real, intent(in ) :: S !< Salinity [PSU] - real, intent(in ) :: P !< pressure [Pa] + real, intent(in ) :: P !< Pressure [Pa] real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect !! to S [kg m-3 PSU-2] real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect @@ -567,13 +529,13 @@ end subroutine calculate_density_second_derivs_scalar_UNESCO !! !! \section section_EOS_UNESCO UNESCO (Jackett & McDougall) equation of state !! -!! The UNESCO (1981) equation of state is an interationally defined standard fit valid over the -!! range of pressures up to 10000 dbar, tempertures between the freezing point and 40 degC, and +!! The UNESCO (1981) equation of state is an internationally defined standard fit valid over the +!! range of pressures up to 10000 dbar, temperatures between the freezing point and 40 degC, and !! salinities between 0 and 42 PSU. Unfortunately, these expressions used in situ temperatures, !! whereas ocean models (including MOM6) effectively use potential temperatures as their state !! variables. To avoid needing multiple conversions, Jackett and McDougall (1995) refit the !! UNESCO equation of state to take potential temperature as a state variable, over the same -!! valid range and funtional form as the original UNESCO expressions. It is this refit from +!! valid range and functional form as the original UNESCO expressions. It is this refit from !! Jackett and McDougall (1995) that is coded up in this module. !! !! The functional form of the equation of state includes terms proportional to salinity to the @@ -583,13 +545,17 @@ end subroutine calculate_density_second_derivs_scalar_UNESCO !! was chosen to imply a contribution that is smaller than numerical roundoff in the expression !! for density, which is the field for which the UNESCO equation of state was originally derived. !! -!! Originally coded in 1999 by J. Stephens. +!! Originally coded in 1999 by J. Stephens, revised in 2023 to unambiguously specify the order +!! of arithmetic with parenthesis in every real sum of three or more terms. !! !! \subsection section_EOS_UNESCO_references References !! -!! Jackett, D. and T. McDougall, 1995: J. Atmos. Ocean. Tech., 12, 381-389. +!! Gill, A. E., 1982: Atmosphere-Ocean Dynamics. Academic Press, 662 pp. +!! +!! Jackett, D. and T. McDougall, 1995: Minimal adjustment of hydrographic profiles to +!! achieve static stability. J. Atmos. Ocean. Tech., 12, 381-389. !! !! UNESCO, 1981: Tenth report of the joint panel on oceanographic tables and standards. -!! UNESCO Technical Palers in Maricen Sci. No. 36, UNESCO, Paris. +!! UNESCO Technical Papers in Marine Sci. No. 36, UNESCO, Paris. end module MOM_EOS_UNESCO From 22729a0a2c63883e9acb3d4505121ee0a0ab6251 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 4 Mar 2023 08:50:54 -0500 Subject: [PATCH 54/91] *Refactor MOM_EOS_NEMO.F90 Refactored the expressions in MOM_EOS_NEMO.F90, adding parentheses to specify the order of arithmetic, starting with the highest-order terms first for less sensitivity to round-off. A number of internal variables were also renamed for greater clarity, and a number of comments were revised to better describe the references for these algorithms.. Although the revised expressions are all mathematically equivalent, this commit will change answers for any cases that use EQN_OF_STATE = "NEMO". However, there is another recent commit to this file that also changes answers (specifically the density derivatives) with this equation of state, and it is believed based on a survey of the MOM6 community that there are no active configurations that use this equation of state. --- src/equation_of_state/MOM_EOS_NEMO.F90 | 508 ++++++++++++------------- 1 file changed, 238 insertions(+), 270 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index b0515ac768..33ea84721f 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -14,38 +14,38 @@ module MOM_EOS_NEMO !> Compute the in situ density of sea water [kg m-3], or its anomaly with respect to !! a reference density, from absolute salinity [g kg-1], conservative temperature [degC], -!! and pressure [Pa], using the expressions derived for use with NEMO +!! and pressure [Pa], using the expressions for density from Roquet et al. (2015) interface calculate_density_nemo module procedure calculate_density_scalar_nemo, calculate_density_array_nemo end interface calculate_density_nemo !> For a given thermodynamic state, return the derivatives of density with conservative temperature -!! and absolute salinity, the expressions derived for use with NEMO +!! and absolute salinity, using the expressions for density from Roquet et al. (2015) interface calculate_density_derivs_nemo module procedure calculate_density_derivs_scalar_nemo, calculate_density_derivs_array_nemo end interface calculate_density_derivs_nemo -!> Compute the second derivatives of density with various combinations -!! of temperature, salinity, and pressure +!> Compute the second derivatives of density with various combinations of temperature, +!! salinity, and pressure using the expressions for density from Roquet et al. (2015) interface calculate_density_second_derivs_nemo module procedure calculate_density_second_derivs_scalar_nemo, calculate_density_second_derivs_array_nemo end interface calculate_density_second_derivs_nemo -real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar [Pa dbar-1] -!>@{ Parameters in the NEMO equation of state -real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] -real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] -real, parameter :: r1_T0 = 1./40. ! The inverse of a plausible range of oceanic temperatures [degC-1] -real, parameter :: r1_P0 = 1.e-4 ! The inverse of a plausible range of oceanic pressures [dbar-1] -real, parameter :: R00 = 4.6494977072e+01 ! Contribution to zr0 proportional to zp [kg m-3] -real, parameter :: R01 = -5.2099962525 ! Contribution to zr0 proportional to zp**2 [kg m-3] -real, parameter :: R02 = 2.2601900708e-01 ! Contribution to zr0 proportional to zp**3 [kg m-3] -real, parameter :: R03 = 6.4326772569e-02 ! Contribution to zr0 proportional to zp**4 [kg m-3] -real, parameter :: R04 = 1.5616995503e-02 ! Contribution to zr0 proportional to zp**5 [kg m-3] -real, parameter :: R05 = -1.7243708991e-03 ! Contribution to zr0 proportional to zp**6 [kg m-3] +real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar [dbar Pa-1] +!>@{ Parameters in the NEMO (Roquet density) equation of state +real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: r1_T0 = 1./40. ! The inverse of a plausible range of oceanic temperatures [degC-1] +real, parameter :: r1_P0 = 1.e-4 ! The inverse of a plausible range of oceanic pressures [dbar-1] +real, parameter :: R00 = 4.6494977072e+01 ! Contribution to rho00p proportional to zp [kg m-3] +real, parameter :: R01 = -5.2099962525 ! Contribution to rho00p proportional to zp**2 [kg m-3] +real, parameter :: R02 = 2.2601900708e-01 ! Contribution to rho00p proportional to zp**3 [kg m-3] +real, parameter :: R03 = 6.4326772569e-02 ! Contribution to rho00p proportional to zp**4 [kg m-3] +real, parameter :: R04 = 1.5616995503e-02 ! Contribution to rho00p proportional to zp**5 [kg m-3] +real, parameter :: R05 = -1.7243708991e-03 ! Contribution to rho00p proportional to zp**6 [kg m-3] ! The following terms are contributions to density as a function of the normalized square root of salinity -! with an offset (zs), temperature (zt) and pressure, with a contribution EOSabc * zs**a * zt**b * zp**c +! with an offset (zs), temperature (zt) and pressure (zp), with a contribution EOSabc * zs**a * zt**b * zp**c real, parameter :: EOS000 = 8.0189615746e+02 ! A constant density contribution [kg m-3] real, parameter :: EOS100 = 8.6672408165e+02 ! Coefficient of the EOS proportional to zs [kg m-3] real, parameter :: EOS200 = -1.7864682637e+03 ! Coefficient of the EOS proportional to zs**2 [kg m-3] @@ -174,16 +174,15 @@ module MOM_EOS_NEMO contains -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature -!! (T [degC]), and pressure [Pa]. It uses the expressions derived for use -!! with NEMO. +!> This subroutine computes the in situ density of sea water (rho in [kg m-3]) +!! from absolute salinity (S [g kg-1]), conservative temperature (T [degC]) +!! and pressure [Pa], using the density polynomial fit EOS from Roquet et al. (2015). subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Conservative temperature [degC]. - real, intent(in) :: S !< Absolute salinity [g kg-1]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: rho !< In situ density [kg m-3]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] @@ -199,32 +198,31 @@ subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_nemo -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature -!! (T [degC]), and pressure [Pa]. It uses the expressions derived for use -!! with NEMO. +!> This subroutine computes an array of in situ densities of sea water (rho in [kg m-3]) +!! from absolute salinity (S [g kg-1]), conservative temperature (T [degC]), and pressure +!! [Pa], using the density polynomial fit EOS from Roquet et al. (2015). subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. - real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, dimension(:), intent(in) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] ! Local variables real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized - ! by an assumed salnity range [nondim] - real :: zr0 ! A pressure-dependent but temperature and salinity independent contribution to - ! density at the reference temperature and salinity [kg m-3] - real :: zn ! Density without a pressure-dependent contribution [kg m-3] - real :: zn0 ! A contribution to density from temperature and salinity anomalies at the surface pressure [kg m-3] - real :: zn1 ! A temperature and salinity dependent density contribution proportional to pressure [kg m-3] - real :: zn2 ! A temperature and salinity dependent density contribution proportional to pressure^2 [kg m-3] - real :: zn3 ! A temperature and salinity dependent density contribution proportional to pressure^3 [kg m-3] - real :: zs0 ! Salinity dependent density at the surface pressure and temperature [kg m-3] + ! by an assumed salinity range [nondim] + real :: rho00p ! A pressure-dependent but temperature and salinity independent contribution to + ! density at the reference temperature and salinity [kg m-3] + real :: rhoTS ! Density without a pressure-dependent contribution [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the surface pressure [kg m-3] + real :: rhoTS1 ! A temperature and salinity dependent density contribution proportional to pressure [kg m-3] + real :: rhoTS2 ! A temperature and salinity dependent density contribution proportional to pressure**2 [kg m-3] + real :: rhoTS3 ! A temperature and salinity dependent density contribution proportional to pressure**3 [kg m-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] integer :: j ! The following algorithm was published by Roquet et al. (2015), intended for use @@ -236,73 +234,70 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] ! The next two lines should be used if it is necessary to convert potential temperature and - ! pratical salinity to conservative temperature and absolute salinity. + ! practical salinity to conservative temperature and absolute salinity. ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. - zn3 = EOS013*zt & - & + EOS103*zs+EOS003 + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) - zn2 = (EOS022*zt & - & + EOS112*zs+EOS012)*zt & - & + (EOS202*zs+EOS102)*zs+EOS002 + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) - zn1 = (((EOS041*zt & - & + EOS131*zs+EOS031)*zt & - & + (EOS221*zs+EOS121)*zs+EOS021)*zt & - & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & - & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) - zn0 = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt + if (present(rho_ref)) rho0S0 = rho0S0 - rho_ref - zs0 = (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs + EOS000 - - zr0 = (((((R05 * zp+R04) * zp+R03 ) * zp+R02 ) * zp+R01) * zp+R00) * zp - - if (present(rho_ref)) then - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + (zn0 + (zs0 - rho_ref)) - rho(j) = ( zn + zr0 ) ! density - else - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + (zn0 + zs0) - rho(j) = ( zn + zr0 ) ! density - endif + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + rho(j) = rhoTS + rho00p ! In situ density [kg m-3] enddo end subroutine calculate_density_array_nemo !> For a given thermodynamic state, calculate the derivatives of density with conservative -!! temperature and absolute salinity, using the expressions derived for use with NEMO. +!! temperature and absolute salinity, using the density polynomial fit EOS from Roquet et al. (2015). subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. - real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + real, intent(in), dimension(:) :: T !< Conservative temperature [degC] + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] + real, intent(in), dimension(:) :: pressure !< Pressure [Pa] + real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with + !! conservative temperature [kg m-3 degC-1] + real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with + !! absolute salinity [kg m-3 ppt-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate ! Local variables real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized - ! by an assumed salnity range [nondim] - real :: zn ! Partial derivative of density with temperature [kg m-3 degC-1] or salinity [kg m-3 ppt-1] - ! without a pressure-dependent contribution - real :: zn0 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] or - ! salinity [kg m-3 ppt-1] from temperature anomalies at the surface pressure - real :: zn1 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] or - ! salinity [kg m-3 ppt-1] proportional to pressure - real :: zn2 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] or - ! salinity [kg m-3 ppt-1] proportional to pressure^2 - real :: zn3 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] or - ! salinity [kg m-3 ppt-1] proportional to pressure^3 + ! by an assumed salinity range [nondim] + real :: dRdzt0 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + ! from temperature anomalies at the surface pressure + real :: dRdzt1 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + ! proportional to pressure + real :: dRdzt2 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + ! proportional to pressure**2 + real :: dRdzt3 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + ! proportional to pressure**3 + real :: dRdzs0 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1] from temperature anomalies at the surface pressure + real :: dRdzs1 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1] proportional to pressure + real :: dRdzs2 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1] proportional to pressure**2 + real :: dRdzs3 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1] proportional to pressure**3 integer :: j do j=start,start+npts-1 @@ -312,75 +307,59 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] ! The next two lines should be used if it is necessary to convert potential temperature and - ! pratical salinity to conservative temperature and absolute salinity. + ! practical salinity to conservative temperature and absolute salinity. ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. - ! - ! alpha - zn3 = ALP003 - ! - zn2 = ALP012*zt + ALP102*zs+ALP002 - ! - zn1 = ((ALP031*zt & - & + ALP121*zs+ALP021)*zt & - & + (ALP211*zs+ALP111)*zs+ALP011)*zt & - & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 - ! - zn0 = ((((ALP050*zt & - & + ALP140*zs+ALP040)*zt & - & + (ALP230*zs+ALP130)*zs+ALP030)*zt & - & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & - & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & - & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 - ! - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + zn0 - ! - drho_dT(j) = zn - ! - ! beta - ! - zn3 = BET003 - ! - zn2 = BET012*zt + BET102*zs+BET002 - ! - zn1 = ((BET031*zt & - & + BET121*zs+BET021)*zt & - & + (BET211*zs+BET111)*zs+BET011)*zt & - & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 - ! - zn0 = ((((BET050*zt & - & + BET140*zs+BET040)*zt & - & + (BET230*zs+BET130)*zs+BET030)*zt & - & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & - & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & - & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 - ! - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + zn0 + ! Find the partial derivative of density with temperature + dRdzt3 = ALP003 + dRdzt2 = ALP002 + (zs*ALP102 + zt*ALP012) + dRdzt1 = ALP001 + (zs*(ALP101 + zs*(ALP201 + zs*ALP301)) & + + zt*(ALP011 + (zs*(ALP111 + zs*ALP211) & + + zt*(ALP021 + (zs*ALP121 + zt*ALP031)) )) ) + dRdzt0 = ALP000 + (zs*(ALP100 + zs*(ALP200 + zs*(ALP300 + zs*(ALP400 + zs*ALP500)))) & + + zt*(ALP010 + (zs*(ALP110 + zs*(ALP210 + zs*(ALP310 + zs*ALP410))) & + + zt*(ALP020 + (zs*(ALP120 + zs*(ALP220 + zs*ALP320)) & + + zt*(ALP030 + (zt*(ALP040 + (zs*ALP140 + zt*ALP050)) & + + zs*(ALP130 + zs*ALP230) )) )) )) ) + + drho_dT(j) = dRdzt0 + zp*(dRdzt1 + zp*(dRdzt2 + zp*dRdzt3)) + + ! Find the partial derivative of density with salinity + dRdzs3 = BET003 + dRdzs2 = BET002 + (zs*BET102 + zt*BET012) + dRdzs1 = BET001 + (zs*(BET101 + zs*(BET201 + zs*BET301)) & + + zt*(BET011 + (zs*(BET111 + zs*BET211) & + + zt*(BET021 + (zs*BET121 + zt*BET031)) )) ) + dRdzs0 = BET000 + (zs*(BET100 + zs*(BET200 + zs*(BET300 + zs*(BET400 + zs*BET500)))) & + + zt*(BET010 + (zs*(BET110 + zs*(BET210 + zs*(BET310 + zs*BET410))) & + + zt*(BET020 + (zs*(BET120 + zs*(BET220 + zs*BET320)) & + + zt*(BET030 + (zt*(BET040 + (zs*BET140 + zt*BET050)) & + + zs*(BET130 + zs*BET230) )) )) )) ) ! The division by zs here is because zs = sqrt(S + S0), so drho_dS = dzs_dS * drho_dzs = (0.5 / zs) * drho_dzs - drho_dS(j) = zn / zs + drho_dS(j) = (dRdzs0 + zp*(dRdzs1 + zp*(dRdzs2 + zp * dRdzs3))) / zs enddo end subroutine calculate_density_derivs_array_nemo !> Wrapper to calculate_density_derivs_array for scalar inputs subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [g kg-1]. - real, intent(in) :: pressure !< Pressure [Pa]. - real, intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1]. + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with + !! conservative temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with + !! absolute salinity [kg m-3 ppt-1] ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] real, dimension(1) :: drdt0 ! A 1-d array with a copy of the derivative of density - ! with potential temperature [kg m-3 degC-1] + ! with conservative temperature [kg m-3 degC-1] real, dimension(1) :: drds0 ! A 1-d array with a copy of the derivative of density - ! with salinity [kg m-3 ppt-1] + ! with absolute salinity [kg m-3 ppt-1] T0(1) = T S0(1) = S @@ -393,33 +372,33 @@ end subroutine calculate_density_derivs_scalar_nemo !> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility !! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), -!! conservative temperature (T [degC]), and pressure [Pa], using the expressions -!! derived for use with NEMO. +!! conservative temperature (T [degC]), and pressure [Pa], using the density polynomial +!! fit EOS from Roquet et al. (2015). subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. - real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. + real, intent(in), dimension(:) :: T !< Conservative temperature [degC] + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] + real, intent(in), dimension(:) :: pressure !< Pressure [Pa] + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3] real, intent(out), dimension(:) :: 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 !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + !! [s2 m-2] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate ! Local variables real :: zp ! Pressure normalized by an assumed pressure range [nondim] real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] real :: zs ! The square root of absolute salinity with an offset normalized - ! by an assumed salnity range [nondim] - real :: dzr0_dp ! Derivative of the pressure-dependent reference density profile with normalized pressure [kg m-3] - real :: dzn_dp ! Derivative of the density anomaly from the reference profile with normalized pressure [kg m-3] - real :: zr0 ! The pressure-dependent (but temperature and salinity independent) reference density profile [kg m-3] - real :: zn ! Density anomaly from the reference profile [kg m-3] - real :: zn0 ! A contribution to density from temperature and salinity anomalies at the surface pressure [kg m-3] - real :: zn1 ! A temperature and salinity dependent density contribution proportional to pressure [kg m-3] - real :: zn2 ! A temperature and salinity dependent density contribution proportional to pressure^2 [kg m-3] - real :: zn3 ! A temperature and salinity dependent density contribution proportional to pressure^3 [kg m-3] - real :: zs0 ! Salinity dependent density at the surface pressure and temperature [kg m-3] + ! by an assumed salinity range [nondim] + real :: drho00p_dp ! Derivative of the pressure-dependent reference density profile with normalized pressure [kg m-3] + real :: drhoTS_dp ! Derivative of the density anomaly from the reference profile with normalized pressure [kg m-3] + real :: rho00p ! The pressure-dependent (but temperature and salinity independent) reference density profile [kg m-3] + real :: rhoTS ! Density anomaly from the reference profile [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the surface pressure [kg m-3] + real :: rhoTS1 ! A temperature and salinity dependent density contribution proportional to pressure [kg m-3] + real :: rhoTS2 ! A temperature and salinity dependent density contribution proportional to pressure**2 [kg m-3] + real :: rhoTS3 ! A temperature and salinity dependent density contribution proportional to pressure**3 [kg m-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] integer :: j ! The following algorithm was published by Roquet et al. (2015), intended for use @@ -431,39 +410,35 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] ! The next two lines should be used if it is necessary to convert potential temperature and - ! pratical salinity to conservative temperature and absolute salinity. + ! practical salinity to conservative temperature and absolute salinity. ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. - zn3 = EOS013*zt + EOS103*zs + EOS003 - - zn2 = (EOS022*zt & - & + EOS112*zs + EOS012)*zt & - & + (EOS202*zs + EOS102)*zs + EOS002 + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) - zn1 = (((EOS041*zt & - & + EOS131*zs + EOS031)*zt & - & + (EOS221*zs + EOS121)*zs + EOS021)*zt & - & + ((EOS311*zs + EOS211)*zs + EOS111)*zs + EOS011)*zt & - & + (((EOS401*zs + EOS301)*zs + EOS201)*zs + EOS101)*zs + EOS001 + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) - zn0 = (((((EOS060*zt & - & + EOS150*zs + EOS050)*zt & - & + (EOS240*zs + EOS140)*zs + EOS040)*zt & - & + ((EOS330*zs + EOS230)*zs + EOS130)*zs + EOS030)*zt & - & + (((EOS420*zs + EOS320)*zs + EOS220)*zs + EOS120)*zs + EOS020)*zt & - & + ((((EOS510*zs + EOS410)*zs + EOS310)*zs + EOS210)*zs + EOS110)*zs + EOS010)*zt + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) - zs0 = (((((EOS600*zs + EOS500)*zs + EOS400)*zs + EOS300)*zs + EOS200)*zs + EOS100)*zs + EOS000 + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) - zr0 = (((((R05*zp + R04)*zp + R03)*zp + R02)*zp + R01)*zp + R00)*zp + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + rho(j) = rhoTS + rho00p ! In situ density [kg m-3] - zn = ( ( zn3*zp + zn2 )*zp + zn1 )*zp + (zn0 + zs0) - rho(j) = ( zn + zr0 ) ! density - - dzr0_dp = ((((6.*R05*zp + 5.*R04)*zp + 4.*R03)*zp + 3.*R02)*zp + 2.*R01)*zp + R00 - dzn_dp = ( 3.*zn3*zp + 2.*zn2 )*zp + zn1 - drho_dp(j) = ( dzn_dp + dzr0_dp ) * (Pa2db*r1_P0) ! density + drho00p_dp = R00 + zp*(2.*R01 + zp*(3.*R02 + zp*(4.*R03 + zp*(5.*R04 + zp*(6.*R05))))) + drhoTS_dp = rhoTS1 + zp*(2.*rhoTS2 + zp*(3.*rhoTS3)) + drho_dp(j) = (drhoTS_dp + drho00p_dp) * (Pa2db*r1_P0) ! Compressibility [s2 m-2] enddo end subroutine calculate_compress_nemo @@ -471,20 +446,20 @@ end subroutine calculate_compress_nemo !> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. subroutine calculate_density_second_derivs_array_NEMO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & - drho_ds_dp, drho_dt_dp, start, npts) - real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] - real, dimension(:), intent(in ) :: S !< Salinity [PSU] + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in ) :: S !< Absolute salinity [PSU] real, dimension(:), intent(in ) :: P !< Pressure [Pa] - real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect - !! to S [kg m-3 PSU-2] - real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect - !! to T [kg m-3 PSU-1 degC-1] - real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect - !! to T [kg m-3 degC-2] - real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect - !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] - real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect - !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + real, dimension(:), intent(inout) :: drho_ds_ds !< Second derivative of density with respect + !! to salinity [kg m-3 ppt-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Second derivative of density with respect + !! to salinity and temperature [kg m-3 ppt-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Second derivative of density with respect + !! to temperature [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Second derivative of density with respect to pressure + !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Second derivative of density with respect to pressure + !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] integer, intent(in ) :: start !< Starting index in T,S,P integer, intent(in ) :: npts !< Number of points to loop over @@ -492,17 +467,12 @@ subroutine calculate_density_second_derivs_array_NEMO(T, S, P, drho_ds_ds, drho_ real :: zp ! Pressure normalized by an assumed pressure range [nondim] real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] real :: zs ! The square root of absolute salinity with an offset normalized - ! by an assumed salnity range [nondim] + ! by an assumed salinity range [nondim] real :: I_s ! The inverse of zs [nondim] - real :: dzr0_dp ! Derivative of the pressure-dependent reference density profile with normalized pressure [kg m-3] - real :: dzn_dp ! Derivative of the density anomaly from the reference profile with normalized pressure [kg m-3] - real :: dzn_ds ! Derivative of the density anomaly from the reference profile with zs [kg m-3] - real :: zr0 ! The pressure-dependent (but temperature and salinity independent) reference density profile [kg m-3] - real :: zn ! Density anomaly from the reference profile [kg m-3] - real :: zn0 ! A contribution to one of the second derivatives that is independent of pressure [various] - real :: zn1 ! A contribution to one of the second derivatives that is proportional to pressure [various] - real :: zn2 ! A contribution to one of the second derivatives that is proportional to pressure^2 [various] - real :: zn3 ! A temperature and salinity dependent density contribution proportional to pressure^3 [various] + real :: d2R_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] + real :: d2R_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] + real :: d2R_p2 ! A contribution to one of the second derivatives that is proportional to pressure**2 [various] + real :: d2R_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] integer :: j do j = start,start+npts-1 @@ -512,62 +482,60 @@ subroutine calculate_density_second_derivs_array_NEMO(T, S, P, drho_ds_ds, drho_ zp = P(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] ! The next two lines should be used if it is necessary to convert potential temperature and - ! pratical salinity to conservative temperature and absolute salinity. + ! practical salinity to conservative temperature and absolute salinity. ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. I_s = 1.0 / zs ! Find drho_ds_ds - zn3 = -EOS103*I_s**2 - zn2 = -(EOS112*zt + EOS102)*I_s**2 - zn1 = (3.*EOS311*zt + (8.*EOS401*zs + 3.*EOS301) ) & - - ( ((EOS131*zt + EOS121)*zt + EOS111)*zt + EOS101 )*I_s**2 - zn0 = ( (( 3.*EOS330*zt + (8.*EOS420*zs + 3.*EOS320))*zt + & - ((15.*EOS510*zs + 8.*EOS410)*zs + 3.*EOS310))*zt + & - (((24.*EOS600*zs + 15.*EOS500)*zs + 8.*EOS400)*zs + 3.*EOS300) ) & - - ( ((((EOS150*zt + EOS140)*zt + EOS130)*zt + EOS120)*zt + EOS110)*zt + EOS100 )*I_s**2 - zn = ( ( zn3 * zp + zn2) * zp + zn1 ) * zp + zn0 - drho_dS_dS(j) = (0.5*r1_S0)**2 * (zn * I_s) + d2R_p3 = -EOS103*I_s**2 + d2R_p2 = -(EOS102 + zt*EOS112)*I_s**2 + d2R_p1 = (3.*EOS301 + (zt*(3.*EOS311) + zs*(8.*EOS401))) & + - ( EOS101 + zt*(EOS111 + zt*(EOS121 + zt*EOS131)) )*I_s**2 + d2R_p0 = (3.*EOS300 + (zs*(8.*EOS400 + zs*(15.*EOS500 + zs*(24.*EOS600))) & + + zt*(3.*EOS310 + (zs*(8.*EOS410 + zs*(15.*EOS510)) & + + zt*(3.*EOS320 + (zs*(8.*EOS420) + zt*(3.*EOS330))) )) )) & + - (EOS100 + zt*(EOS110 + zt*(EOS120 + zt*(EOS130 + zt*(EOS140 + zt*EOS150)))) )*I_s**2 + drho_dS_dS(j) = (0.5*r1_S0)**2 * ((d2R_p0 + zp*(d2R_p1 + zp*(d2R_p2 + zp*d2R_p3))) * I_s) ! Find drho_ds_dt - zn2 = EOS112 - zn1 = ((3.*EOS131)*zt + (4.*EOS221*zs + 2.*EOS121))*zt + & - ((3.*EOS311*zs + 2.*EOS211)*zs + EOS111) - zn0 = (((5.*EOS150*zt + (8.*EOS240*zs + 4.*EOS140))*zt + & - ((9.*EOS330*zs + 6.*EOS230)*zs + 3.*EOS130))*zt + & - ((((8.*EOS420*zs + 6.*EOS320)*zs + 4.*EOS220)*zs + 2.*EOS120)))*zt + & - ((((5.*EOS510*zs + 4.*EOS410)*zs + 3.*EOS310)*zs + 2.*EOS210)*zs + EOS110) - zn = ( zn2 * zp + zn1 ) * zp + zn0 - drho_ds_dt(j) = (0.5*r1_S0*r1_T0) * (zn * I_s) + d2R_p2 = EOS112 + d2R_p1 = EOS111 + (zs*(2.*EOS211 + zs*(3.*EOS311)) & + + zt*(2.*EOS121 + (zs*(4.*EOS221) + zt*(3.*EOS131))) ) + d2R_p0 = EOS110 + (zs*(2.*EOS210 + zs*(3.*EOS310 + zs*(4.*EOS410 + zs*(5.*EOS510)))) & + + zt*(2.*EOS120 + (zs*(4.*EOS220 + zs*(6.*EOS320 + zs*(8.*EOS420))) & + + zt*(3.*EOS130 + (zs*(6.*EOS230 + zs*(9.*EOS330)) & + + zt*(4.*EOS140 + (zs*(8.*EOS240) & + + zt*(5.*EOS150))) )) )) ) + drho_ds_dt(j) = (0.5*r1_S0*r1_T0) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) ! Find drho_dt_dt - zn2 = 2.*EOS022 - zn1 = (12.*EOS041*zt + 6.*(EOS131*zs + EOS031))*zt + & - 2.*((EOS221*zs + EOS121)*zs + EOS021) - zn0 = (((30.*EOS060*zt + 20.*(EOS150*zs + EOS050))*zt + & - 12.*((EOS240*zs + EOS140)*zs + EOS040))*zt + & - 6.*(((EOS330*zs + EOS230)*zs + EOS130)*zs + EOS030))*zt + & - 2.*((((EOS420*zs + EOS320)*zs + EOS220)*zs + EOS120)*zs + EOS020) - zn = ( zn2 * zp + zn1 ) * zp + zn0 - drho_dt_dt(j) = zn * r1_T0**2 + d2R_p2 = 2.*EOS022 + d2R_p1 = 2.*EOS021 + (zs*(2.*EOS121 + zs*(2.*EOS221)) & + + zt*(6.*EOS031 + (zs*(6.*EOS131) + zt*(12.*EOS041))) ) + d2R_p0 = 2.*EOS020 + (zs*(2.*EOS120 + zs*( 2.*EOS220 + zs*( 2.*EOS320 + zs * (2.*EOS420)))) & + + zt*(6.*EOS030 + (zs*( 6.*EOS130 + zs*( 6.*EOS230 + zs * (6.*EOS330))) & + + zt*(12.*EOS040 + (zs*(12.*EOS140 + zs *(12.*EOS240)) & + + zt*(20.*EOS050 + (zs*(20.*EOS150) & + + zt*(30.*EOS060) )) )) )) ) + drho_dt_dt(j) = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * r1_T0**2 ! Find drho_ds_dp - zn3 = EOS103 - zn2 = EOS112*zt + (2.*EOS202*zs + EOS102) - zn1 = ((EOS131*zt + (2.*EOS221*zs + EOS121))*zt + ((3.*EOS311*zs + 2.*EOS211)*zs + EOS111))*zt + & - (((4.*EOS401*zs + 3.*EOS301)*zs + 2.*EOS201)*zs + EOS101) - dzn_dp = ( ( 3.*zn3 * zp + 2.*zn2 ) * zp + zn1 ) - drho_ds_dp(j) = ( dzn_dp * I_s ) * (0.5*r1_S0 * Pa2db*r1_P0) ! Second derivative of density - + d2R_p2 = 3.*EOS103 + d2R_p1 = 2.*EOS102 + (zs*(4.*EOS202) + zt*(2.*EOS112)) + d2R_p0 = EOS101 + (zs*(2.*EOS201 + zs*(3.*EOS301 + zs*(4.*EOS401))) & + + zt*(EOS111 + (zs*(2.*EOS211 + zs*(3.*EOS311)) & + + zt*( EOS121 + (zs*(2.*EOS221) + zt*EOS131)) )) ) + drho_ds_dp(j) = ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) * (0.5*r1_S0 * Pa2db*r1_P0) ! Find drho_dt_dp - zn3 = EOS013 - zn2 = 2.*EOS022*zt + (EOS112*zs + EOS012) - zn1 = ((4.*EOS041*zt + 3.*(EOS131*zs + EOS031))*zt + 2.*((EOS221*zs + EOS121)*zs + EOS021))*zt + & - (((EOS311*zs + EOS211)*zs + EOS111)*zs + EOS011) - dzn_dp = ( ( 3.*zn3 * zp + 2.*zn2 ) * zp + zn1 ) - drho_dt_dp(j) = ( dzn_dp ) * (Pa2db*r1_P0* r1_T0) ! Second derivative of density + d2R_p2 = 3.*EOS013 + d2R_p1 = 2.*EOS012 + (zs*(2.*EOS112) + zt*(4.*EOS022)) + d2R_p0 = EOS011 + (zs*(EOS111 + zs*( EOS211 + zs* EOS311)) & + + zt*(2.*EOS021 + (zs*(2.*EOS121 + zs*(2.*EOS221)) & + + zt*(3.*EOS031 + (zs*(3.*EOS131) + zt*(4.*EOS041))) )) ) + drho_dt_dp(j) = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * (Pa2db*r1_P0* r1_T0) enddo end subroutine calculate_density_second_derivs_array_NEMO @@ -577,20 +545,20 @@ end subroutine calculate_density_second_derivs_array_NEMO !! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array !! and then demotes the output back to a scalar subroutine calculate_density_second_derivs_scalar_NEMO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & - drho_ds_dp, drho_dt_dp) - real, intent(in ) :: T !< Potential temperature referenced to 0 dbar - real, intent(in ) :: S !< Salinity [PSU] + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Conservative temperature [degC] + real, intent(in ) :: S !< Absolute salinity [PSU] real, intent(in ) :: P !< pressure [Pa] - real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect - !! to S [kg m-3 PSU-2] - real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect - !! to T [kg m-3 PSU-1 degC-1] - real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect - !! to T [kg m-3 degC-2] - real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect - !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] - real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect - !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + real, intent( out) :: drho_ds_ds !< Second derivative of density with respect + !! to salinity [kg m-3 ppt-2] + real, intent( out) :: drho_ds_dt !< Second derivative of density with respect + !! to salinity and temperature [kg m-3 ppt-1 degC-1] + real, intent( out) :: drho_dt_dt !< Second derivative of density with respect + !! to temperature [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Second derivative of density with respect to pressure + !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, intent( out) :: drho_dt_dp !< Second derivative of density with respect to pressure + !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] @@ -631,7 +599,7 @@ end subroutine calculate_density_second_derivs_scalar_NEMO !! !! The NEMO label used to describe this equation of state reflects that it was used in the NEMO !! ocean model before it was used in MOM6, but it probably should be described as the Roquet -!! equation of. However, these algorithms, especially as modified here, are not from +!! equation of state. However, these algorithms, especially as modified here, are not from !! the standard NEMO codebase. !! !! \subsection section_EOS_NEMO_references References From 493cfe524e2f22a8e83f32327fe6bf126a9a2982 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 4 Mar 2023 08:51:17 -0500 Subject: [PATCH 55/91] +Add MOM_EOS_Roquet_SpV.F90 Added the new equation of state module MOM_EOS_Roquet_SpV with the polynomial specific volume fit equation of state from Roquet et al. (2015). This equation of state has also been added to MOM_EOS, where it is enabled by setting EQN_OF_STATE="ROQUET_SPV". Two other new valid settings have been added to EQN_OF_STATE, "ROQUET_RHO" and "JACKETT_MCD", which synonymous with "NEMO" and "UNESCO" respectively, but more accurately reflect the publications that describe these fits to the equation of state. The EoS unit tests are being called for the new equation of state (it passes). By default, all answers are bitwise identical, but there are numerous new publicly visible interfaces. --- src/equation_of_state/MOM_EOS.F90 | 134 +++- src/equation_of_state/MOM_EOS_Roquet_SpV.F90 | 790 +++++++++++++++++++ 2 files changed, 890 insertions(+), 34 deletions(-) create mode 100644 src/equation_of_state/MOM_EOS_Roquet_SpV.F90 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 0932758432..bd5965907c 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -28,9 +28,13 @@ module MOM_EOS use MOM_EOS_UNESCO, only : calculate_density_second_derivs_UNESCO use MOM_EOS_UNESCO, only : calculate_compress_unesco use MOM_EOS_NEMO, only : calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo +use MOM_EOS_NEMO, only : calculate_density_derivs_nemo use MOM_EOS_NEMO, only : calculate_density_second_derivs_NEMO use MOM_EOS_NEMO, only : calculate_compress_nemo +use MOM_EOS_Roquet_SpV, only : calculate_density_Roquet_SpV, calculate_spec_vol_Roquet_SpV +use MOM_EOS_Roquet_SpV, only : calculate_density_derivs_Roquet_SpV, calculate_specvol_derivs_Roquet_SpV +use MOM_EOS_Roquet_SpV, only : calculate_compress_Roquet_SpV +use MOM_EOS_Roquet_SpV, only : calculate_density_second_derivs_Roquet_SpV use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 @@ -169,14 +173,18 @@ module MOM_EOS integer, parameter, public :: EOS_WRIGHT_RED = 5 !< A named integer specifying an equation of state integer, parameter, public :: EOS_TEOS10 = 6 !< A named integer specifying an equation of state integer, parameter, public :: EOS_NEMO = 7 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_ROQUET_SPV = 8 !< A named integer specifying an equation of state -character*(10), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state -character*(10), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state -character*(10), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state +character*(12), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state +character*(12), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_JACKETT_STRING = "JACKETT_MCD" !< A string for specifying the equation of state +character*(12), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state character*(12), parameter :: EOS_WRIGHT_RED_STRING = "WRIGHT_RED" !< A string for specifying the equation of state character*(12), parameter :: EOS_WRIGHT_FULL_STRING = "WRIGHT_FULL" !< A string for specifying the equation of state -character*(10), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state -character*(10), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state +character*(12), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_ROQUET_RHO_STRING = "ROQUET_RHO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_ROQUET_SPV_STRING = "ROQUET_SPV" !< A string for specifying the equation of state character*(12), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression @@ -281,6 +289,9 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r case (EOS_NEMO) call calculate_density_second_derivs_NEMO(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) + case (EOS_ROQUET_SPV) + call calculate_density_second_derivs_Roquet_SpV(T_scale*T, S_scale*S, p_scale*pressure, & + d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) @@ -327,7 +338,9 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_ROQUET_SPV) + call calculate_density_Roquet_SpV(T, S, pressure, rho, start, npts, rho_ref) case default call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") end select @@ -397,6 +410,10 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh call calculate_density_NEMO(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_NEMO(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_ROQUET_SPV) + call calculate_density_Roquet_SpV(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_Roquet_SpV(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & @@ -557,6 +574,10 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, call calculate_density_NEMO(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_NEMO(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) + case (EOS_ROQUET_SPV) + call calculate_density_Roquet_SpV(Ta, Sa, pres, rho, is, npts, rho_reference) + call calculate_density_second_derivs_Roquet_SpV(Ta, Sa, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, is, npts) case (EOS_TEOS10) call calculate_density_teos10(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_teos10(Ta, Sa, pres, d2RdSS, d2RdST, & @@ -618,6 +639,8 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s else specvol(:) = 1.0 / rho(:) endif + case (EOS_ROQUET_SpV) + call calculate_spec_vol_Roquet_SpV(T, S, pressure, specvol, start, npts, spv_ref) case default call MOM_error(FATAL, "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") end select @@ -904,6 +927,8 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_NEMO) call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_ROQUET_SPV) + call calculate_density_derivs_Roquet_SpV(T, S, pressure, drho_dT, drho_dS, start, npts) case default call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") end select @@ -1085,6 +1110,9 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_NEMO) call calculate_density_second_derivs_NEMO(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_ROQUET_SPV) + call calculate_density_second_derivs_Roquet_SpV(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1121,6 +1149,9 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_NEMO) call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_ROQUET_SpV) + call calculate_density_second_derivs_Roquet_SpV(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) @@ -1211,6 +1242,9 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr case (EOS_NEMO) call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) + case (EOS_ROQUET_SPV) + call calculate_density_second_derivs_Roquet_SpV(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) @@ -1292,6 +1326,8 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) enddo + case (EOS_ROQUET_SPV) + call calculate_specvol_derivs_Roquet_SpV(T, S, pressure, dSV_dT, dSV_dS, start, npts) case default call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") end select @@ -1400,6 +1436,8 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) call calculate_compress_teos10(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_NEMO) call calculate_compress_nemo(Ta, Sa, pres, rho, drho_dp, is, npts) + case (EOS_ROQUET_SpV) + call calculate_compress_Roquet_SpV(Ta, Sa, pres, rho, drho_dp, is, npts) case default call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") end select @@ -1511,7 +1549,6 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] - ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical ! integration be used instead of analytic. This is a safety check. if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") @@ -1686,14 +1723,16 @@ subroutine EOS_init(param_file, EOS, US) call get_param(param_file, mdl, "EQN_OF_STATE", tmpstr, & "EQN_OF_STATE determines which ocean equation of state should be used. "//& - 'Currently, the valid choices are "LINEAR", "UNESCO", '//& - '"WRIGHT", "WRIGHT_RED", "WRIGHT_FULL", "NEMO" and "TEOS10". '//& - "This is only used if USE_EOS is true.", default=EOS_DEFAULT) + 'Currently, the valid choices are "LINEAR", "UNESCO", "JACKETT_MCD", '//& + '"WRIGHT", "WRIGHT_RED", "WRIGHT_FULL", "NEMO", "ROQUET_RHO", "ROQUET_SPV" '//& + 'and "TEOS10". This is only used if USE_EOS is true.', default=EOS_DEFAULT) select case (uppercase(tmpstr)) case (EOS_LINEAR_STRING) EOS%form_of_EOS = EOS_LINEAR case (EOS_UNESCO_STRING) EOS%form_of_EOS = EOS_UNESCO + case (EOS_JACKETT_STRING) + EOS%form_of_EOS = EOS_UNESCO case (EOS_WRIGHT_STRING) EOS%form_of_EOS = EOS_WRIGHT case (EOS_WRIGHT_RED_STRING) @@ -1704,6 +1743,10 @@ subroutine EOS_init(param_file, EOS, US) EOS%form_of_EOS = EOS_TEOS10 case (EOS_NEMO_STRING) EOS%form_of_EOS = EOS_NEMO + case (EOS_ROQUET_RHO_STRING) + EOS%form_of_EOS = EOS_NEMO + case (EOS_ROQUET_SPV_STRING) + EOS%form_of_EOS = EOS_ROQUET_SPV case default call MOM_error(FATAL, "interpret_eos_selection: EQN_OF_STATE "//& trim(tmpstr) // " in input file is invalid.") @@ -1741,7 +1784,8 @@ subroutine EOS_init(param_file, EOS, US) "code for the integrals of density.", default=EOS_quad_default) TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING - if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO)) & + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO .or. & + EOS%form_of_EOS == EOS_ROQUET_SPV)) & TFREEZE_DEFAULT = TFREEZE_TEOS10_STRING call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & "TFREEZE_FORM determines which expression should be "//& @@ -1777,9 +1821,9 @@ subroutine EOS_init(param_file, EOS, US) units="deg C Pa-1", default=0.0) endif - if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO) .and. & + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO .or. EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & (EOS%form_of_TFreeze /= TFREEZE_TEOS10)) then - call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO "//& + call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO or EOS_ROQUET_SPV "//& "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") endif @@ -1870,7 +1914,8 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) real :: gsw_ct_from_pt ! Conservative temperature after conversion from potential temperature [degC] integer :: i, j, k - if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return + if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO) .and. & + (EOS%form_of_EOS /= EOS_ROQUET_SPV)) return do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec if (mask_z(i,j,k) >= 1.0) then @@ -1886,7 +1931,7 @@ end subroutine convert_temp_salt_for_TEOS10 !> Converts an array of conservative temperatures to potential temperatures. The input arguments -!! use the dimesionally rescaling as specified within the EOS type. The output potential +!! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) real, dimension(:), intent(in) :: T !< Conservative temperature [C ~> degC] @@ -1933,7 +1978,7 @@ end subroutine cons_temp_to_pot_temp !> Converts an array of absolute salinity to practical salinity. The input arguments -!! use the dimesionally rescaling as specified within the EOS type. The output potential +!! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] @@ -2029,44 +2074,65 @@ logical function EOS_unit_tests(verbose) call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_UNESCO) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "UNESCO", & - rho_check=1027.5434579611974*EOS_tmp%kg_m3_to_R) + rho_check=1027.54345796120*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "UNESCO EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_FULL) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_FULL", & - rho_check=1027.5517744761617*EOS_tmp%kg_m3_to_R) + rho_check=1027.55177447616*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_FULL EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_RED) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_RED", & - rho_check=1027.5430359634624*EOS_tmp%kg_m3_to_R) + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_RED EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & - rho_check=1027.5430359634624*EOS_tmp%kg_m3_to_R) + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_NEMO) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "NEMO", & - rho_check=1027.4238566366823*EOS_tmp%kg_m3_to_R) + rho_check=1027.42385663668*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "ROQUET_SPV", & + rho_check=1027.42387475199*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + ! The TEOS10 equation of state is not passing the self consistency tests for dho_dS_dp due ! to a bug (a missing division by the square root of salinity) on line 109 of ! pkg/GSW-Fortan/toolbox/gsw_specvol_second_derivatives.f90. This bug has been highlighted in an ! issue posted to the TEOS-10/GSW-Fortran page at github.com/TEOS-10/GSW-Fortran/issues/26. call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", skip_2nd=.true., & - rho_check=1027.4235596149185*EOS_tmp%kg_m3_to_R) + rho_check=1027.42355961492*EOS_tmp%kg_m3_to_R) if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_NEMO) + fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "NEMO", & + rho_check=1027.45140117152*EOS_tmp%kg_m3_to_R) + ! The corresponding check value published by Roquet et al. (2015) is 1027.45140 [kg m-3]. + if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) + fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "ROQUET_SPV", & + spv_check=9.73282046614623e-04*EOS_tmp%R_to_kg_m3) + ! The corresponding check value here published by Roquet et al. (2015) is 9.732819628e-04 [m3 kg-1], + ! but the order of arithmetic there was not completely specified with parentheses. + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", & rho_check=1023.0*EOS_tmp%kg_m3_to_R) @@ -2094,7 +2160,7 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & ! Local variables real, dimension(-3:3,-3:3,-3:3) :: T ! Temperatures at the test value and perturbed points [C ~> degC] - real, dimension(-3:3,-3:3,-3:3) :: S ! Salinites at the test value and perturbed points [S ~> ppt] + real, dimension(-3:3,-3:3,-3:3) :: S ! Salinities at the test value and perturbed points [S ~> ppt] real, dimension(-3:3,-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] real, dimension(-3:3,-3:3,-3:3,2) :: rho ! Densities relative to rho_ref at the test value and ! perturbed points [R ~> kg m-3] @@ -2176,7 +2242,7 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & do n=1,2 ! Calculate density values with a wide enough stencil to estimate first and second derivatives - ! with up to 6th order accuracy. Doing this twice with different sizes of pertubations allows + ! with up to 6th order accuracy. Doing this twice with different sizes of perturbations allows ! the evaluation of whether the finite differences are converging to the calculated values at a ! rate that is consistent with the order of accuracy of the finite difference forms, and hence ! the consistency of the calculated values. @@ -2300,9 +2366,9 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & contains - !> Return a finite difference estimate of the first derivative of a field in arbitary units [A B-1] + !> Return a finite difference estimate of the first derivative of a field in arbitrary units [A B-1] real function first_deriv(R, dx, order) - real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in abitrary units [A] + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in arbitrary units [A] real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) @@ -2315,9 +2381,9 @@ real function first_deriv(R, dx, order) endif end function first_deriv - !> Return a finite difference estimate of the second derivative of a field in arbitary units [A B-2] + !> Return a finite difference estimate of the second derivative of a field in arbitrary units [A B-2] real function second_deriv(R, dx, order) - real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in abitrary units [A] + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in arbitrary units [A] real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) @@ -2331,9 +2397,9 @@ real function second_deriv(R, dx, order) end function second_deriv !> Return a finite difference estimate of the second derivative with respect to two different - !! parameters of a field in arbitary units [A B-2] + !! parameters of a field in arbitrary units [A B-1 C-1] real function derivs_2d(R, dxdy, order) - real, intent(in) :: R(-3:3,-3:3) !< The field whose derivative is being taken in abitrary units [A] + real, intent(in) :: R(-3:3,-3:3) !< The field whose derivative is being taken in arbitrary units [A] real, intent(in) :: dxdy !< The spacing in two directions in parameter space in different arbitrary units [B C] integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) @@ -2386,6 +2452,6 @@ end module MOM_EOS !> \namespace mom_eos !! -!! The MOM_EOS module is a wrapper for various equations of state (e.g. Linear, -!! Wright, UNESCO, TEOS10 or NEMO) and provides a uniform interface to the rest of the model -!! independent of which equation of state is being used. +!! The MOM_EOS module is a wrapper for various equations of state (i.e. Linear, Wright, +!! Wright_full, Wright_red, UNESCO, TEOS10, Roquet_SpV or NEMO) and provides a uniform +!! interface to the rest of the model independent of which equation of state is being used. diff --git a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 new file mode 100644 index 0000000000..5a276065dd --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 @@ -0,0 +1,790 @@ +!> The equation of state for specific volume (SpV) using the expressions of Roquet et al. 2015 +module MOM_EOS_Roquet_Spv + +! This file is part of MOM6. See LICENSE.md for the license. + +!use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt + +implicit none ; private + +public calculate_compress_Roquet_SpV, calculate_density_Roquet_SpV, calculate_spec_vol_Roquet_SpV +public calculate_density_derivs_Roquet_SpV, calculate_specvol_derivs_Roquet_SpV +public calculate_density_scalar_Roquet_SpV, calculate_density_array_Roquet_SpV +public calculate_density_second_derivs_Roquet_SpV + +!> Compute the in situ density of sea water [kg m-3], or its anomaly with respect to +!! a reference density, from absolute salinity [g kg-1], conservative temperature [degC], +!! and pressure [Pa], using the specific volume polynomial fit from Roquet et al. (2015) +interface calculate_density_Roquet_SpV + module procedure calculate_density_scalar_Roquet_SpV, calculate_density_array_Roquet_SpV +end interface calculate_density_Roquet_SpV + +!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect +!! to a reference specific volume, from absolute salinity ([g kg-1]), conservative +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the specific volume +!! polynomial fit from Roquet et al. (2015) +interface calculate_spec_vol_Roquet_SpV + module procedure calculate_spec_vol_scalar_Roquet_SpV, calculate_spec_vol_array_Roquet_SpV +end interface calculate_spec_vol_Roquet_SpV + +!> For a given thermodynamic state, return the derivatives of density with conservative temperature +!! and absolute salinity, using the specific volume polynomial fit from Roquet et al. (2015) +interface calculate_density_derivs_Roquet_SpV + module procedure calculate_density_derivs_scalar_Roquet_SpV, calculate_density_derivs_array_Roquet_SpV +end interface calculate_density_derivs_Roquet_SpV + +!> Compute the second derivatives of density with various combinations of temperature, salinity +!! and pressure using the specific volume polynomial fit from Roquet et al. (2015) +interface calculate_density_second_derivs_Roquet_SpV + module procedure calculate_density_second_derivs_scalar_Roquet_SpV + module procedure calculate_density_second_derivs_array_Roquet_SpV +end interface calculate_density_second_derivs_Roquet_SpV + +real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar [dbar Pa-1] +!>@{ Parameters in the Roquet specific volume polynomial equation of state +real, parameter :: rdeltaS = 24. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: r1_T0 = 1./40. ! The inverse of a plausible range of oceanic temperatures [degC-1] +real, parameter :: r1_P0 = 1.e-4 ! The inverse of a plausible range of oceanic pressures [dbar-1] +real, parameter :: V00 = -4.4015007269e-05 ! Contribution to SpV00p proportional to zp [m3 kg-1] +real, parameter :: V01 = 6.9232335784e-06 ! Contribution to SpV00p proportional to zp**2 [m3 kg-1] +real, parameter :: V02 = -7.5004675975e-07 ! Contribution to SpV00p proportional to zp**3 [m3 kg-1] +real, parameter :: V03 = 1.7009109288e-08 ! Contribution to SpV00p proportional to zp**4 [m3 kg-1] +real, parameter :: V04 = -1.6884162004e-08 ! Contribution to SpV00p proportional to zp**5 [m3 kg-1] +real, parameter :: V05 = 1.9613503930e-09 ! Contribution to SpV00p proportional to zp**6 [m3 kg-1] + +! The following terms are contributions to specific volume as a function of the normalized square root of salinity +! with an offset (zs), temperature (zt) and pressure (zp), with a contribution SPVabc * zs**a * zt**b * zp**c +real, parameter :: SPV000 = 1.0772899069e-03 ! A constant specific volume (SpV) contribution [m3 kg-1] +real, parameter :: SPV100 = -3.1263658781e-04 ! Coefficient of SpV proportional to zs [m3 kg-1] +real, parameter :: SPV200 = 6.7615860683e-04 ! Coefficient of SpV proportional to zs**2 [m3 kg-1] +real, parameter :: SPV300 = -8.6127884515e-04 ! Coefficient of SpV proportional to zs**3 [m3 kg-1] +real, parameter :: SPV400 = 5.9010812596e-04 ! Coefficient of SpV proportional to zs**4 [m3 kg-1] +real, parameter :: SPV500 = -2.1503943538e-04 ! Coefficient of SpV proportional to zs**5 [m3 kg-1] +real, parameter :: SPV600 = 3.2678954455e-05 ! Coefficient of SpV proportional to zs**6 [m3 kg-1] +real, parameter :: SPV010 = -1.4949652640e-05 ! Coefficient of SpV proportional to zt [m3 kg-1] +real, parameter :: SPV110 = 3.1866349188e-05 ! Coefficient of SpV proportional to zs * zt [m3 kg-1] +real, parameter :: SPV210 = -3.8070687610e-05 ! Coefficient of SpV proportional to zs**2 * zt [m3 kg-1] +real, parameter :: SPV310 = 2.9818473563e-05 ! Coefficient of SpV proportional to zs**3 * zt [m3 kg-1] +real, parameter :: SPV410 = -1.0011321965e-05 ! Coefficient of SpV proportional to zs**4 * zt [m3 kg-1] +real, parameter :: SPV510 = 1.0751931163e-06 ! Coefficient of SpV proportional to zs**5 * zt [m3 kg-1] +real, parameter :: SPV020 = 2.7546851539e-05 ! Coefficient of SpV proportional to zt**2 [m3 kg-1] +real, parameter :: SPV120 = -3.6597334199e-05 ! Coefficient of SpV proportional to zs * zt**2 [m3 kg-1] +real, parameter :: SPV220 = 3.4489154625e-05 ! Coefficient of SpV proportional to zs**2 * zt**2 [m3 kg-1] +real, parameter :: SPV320 = -1.7663254122e-05 ! Coefficient of SpV proportional to zs**3 * zt**2 [m3 kg-1] +real, parameter :: SPV420 = 3.5965131935e-06 ! Coefficient of SpV proportional to zs**4 * zt**2 [m3 kg-1] +real, parameter :: SPV030 = -1.6506828994e-05 ! Coefficient of SpV proportional to zt**3 [m3 kg-1] +real, parameter :: SPV130 = 2.4412359055e-05 ! Coefficient of SpV proportional to zs * zt**3 [m3 kg-1] +real, parameter :: SPV230 = -1.4606740723e-05 ! Coefficient of SpV proportional to zs**2 * zt**3 [m3 kg-1] +real, parameter :: SPV330 = 2.3293406656e-06 ! Coefficient of SpV proportional to zs**3 * zt**3 [m3 kg-1] +real, parameter :: SPV040 = 6.7896174634e-06 ! Coefficient of SpV proportional to zt**4 [m3 kg-1] +real, parameter :: SPV140 = -8.7951832993e-06 ! Coefficient of SpV proportional to zs * zt**4 [m3 kg-1] +real, parameter :: SPV240 = 4.4249040774e-06 ! Coefficient of SpV proportional to zs**2 * zt**4 [m3 kg-1] +real, parameter :: SPV050 = -7.2535743349e-07 ! Coefficient of SpV proportional to zt**5 [m3 kg-1] +real, parameter :: SPV150 = -3.4680559205e-07 ! Coefficient of SpV proportional to zs * zt**5 [m3 kg-1] +real, parameter :: SPV060 = 1.9041365570e-07 ! Coefficient of SpV proportional to zt**6 [m3 kg-1] +real, parameter :: SPV001 = -1.6889436589e-05 ! Coefficient of SpV proportional to zp [m3 kg-1] +real, parameter :: SPV101 = 2.1106556158e-05 ! Coefficient of SpV proportional to zs * zp [m3 kg-1] +real, parameter :: SPV201 = -2.1322804368e-05 ! Coefficient of SpV proportional to zs**2 * zp [m3 kg-1] +real, parameter :: SPV301 = 1.7347655458e-05 ! Coefficient of SpV proportional to zs**3 * zp [m3 kg-1] +real, parameter :: SPV401 = -4.3209400767e-06 ! Coefficient of SpV proportional to zs**4 * zp [m3 kg-1] +real, parameter :: SPV011 = 1.5355844621e-05 ! Coefficient of SpV proportional to zt * zp [m3 kg-1] +real, parameter :: SPV111 = 2.0914122241e-06 ! Coefficient of SpV proportional to zs * zt * zp [m3 kg-1] +real, parameter :: SPV211 = -5.7751479725e-06 ! Coefficient of SpV proportional to zs**2 * zt * zp [m3 kg-1] +real, parameter :: SPV311 = 1.0767234341e-06 ! Coefficient of SpV proportional to zs**3 * zt * zp [m3 kg-1] +real, parameter :: SPV021 = -9.6659393016e-06 ! Coefficient of SpV proportional to zt**2 * zp [m3 kg-1] +real, parameter :: SPV121 = -7.0686982208e-07 ! Coefficient of SpV proportional to zs * zt**2 * zp [m3 kg-1] +real, parameter :: SPV221 = 1.4488066593e-06 ! Coefficient of SpV proportional to zs**2 * zt**2 * zp [m3 kg-1] +real, parameter :: SPV031 = 3.1134283336e-06 ! Coefficient of SpV proportional to zt**3 * zp [m3 kg-1] +real, parameter :: SPV131 = 7.9562529879e-08 ! Coefficient of SpV proportional to zs * zt**3 * zp [m3 kg-1] +real, parameter :: SPV041 = -5.6590253863e-07 ! Coefficient of SpV proportional to zt * zp [m3 kg-1] +real, parameter :: SPV002 = 1.0500241168e-06 ! Coefficient of SpV proportional to zp**2 [m3 kg-1] +real, parameter :: SPV102 = 1.9600661704e-06 ! Coefficient of SpV proportional to zs * zp**2 [m3 kg-1] +real, parameter :: SPV202 = -2.1666693382e-06 ! Coefficient of SpV proportional to zs**2 * zp**2 [m3 kg-1] +real, parameter :: SPV012 = -3.8541359685e-06 ! Coefficient of SpV proportional to zt * zp**2 [m3 kg-1] +real, parameter :: SPV112 = 1.0157632247e-06 ! Coefficient of SpV proportional to zs * zt * zp**2 [m3 kg-1] +real, parameter :: SPV022 = 1.7178343158e-06 ! Coefficient of SpV proportional to zt**2 * zp**2 [m3 kg-1] +real, parameter :: SPV003 = -4.1503454190e-07 ! Coefficient of SpV proportional to zp**3 [m3 kg-1] +real, parameter :: SPV103 = 3.5627020989e-07 ! Coefficient of SpV proportional to zs * zp**3 [m3 kg-1] +real, parameter :: SPV013 = -1.1293871415e-07 ! Coefficient of SpV proportional to zt * zp**3 [m3 kg-1] + +real, parameter :: ALP000 = SPV010*r1_T0 ! Constant in the dSpV_dT fit [m3 kg-1 degC-1] +real, parameter :: ALP100 = SPV110*r1_T0 ! Coefficient of the dSpV_dT fit zs term [m3 kg-1 degC-1] +real, parameter :: ALP200 = SPV210*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 term [m3 kg-1 degC-1] +real, parameter :: ALP300 = SPV310*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 term [m3 kg-1 degC-1] +real, parameter :: ALP400 = SPV410*r1_T0 ! Coefficient of the dSpV_dT fit zs**4 term [m3 kg-1 degC-1] +real, parameter :: ALP500 = SPV510*r1_T0 ! Coefficient of the dSpV_dT fit zs**5 term [m3 kg-1 degC-1] +real, parameter :: ALP010 = 2.*SPV020*r1_T0 ! Coefficient of the dSpV_dT fit zt term [m3 kg-1 degC-1] +real, parameter :: ALP110 = 2.*SPV120*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt term [m3 kg-1 degC-1] +real, parameter :: ALP210 = 2.*SPV220*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt term [m3 kg-1 degC-1] +real, parameter :: ALP310 = 2.*SPV320*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 * zt term [m3 kg-1 degC-1] +real, parameter :: ALP410 = 2.*SPV420*r1_T0 ! Coefficient of the dSpV_dT fit zs**4 * zt term [m3 kg-1 degC-1] +real, parameter :: ALP020 = 3.*SPV030*r1_T0 ! Coefficient of the dSpV_dT fit zt**2 term [m3 kg-1 degC-1] +real, parameter :: ALP120 = 3.*SPV130*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt**2 term [m3 kg-1 degC-1] +real, parameter :: ALP220 = 3.*SPV230*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt**2 term [m3 kg-1 degC-1] +real, parameter :: ALP320 = 3.*SPV330*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 * zt**2 term [m3 kg-1 degC-1] +real, parameter :: ALP030 = 4.*SPV040*r1_T0 ! Coefficient of the dSpV_dT fit zt**3 term [m3 kg-1 degC-1] +real, parameter :: ALP130 = 4.*SPV140*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt**3 term [m3 kg-1 degC-1] +real, parameter :: ALP230 = 4.*SPV240*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt**3 term [m3 kg-1 degC-1] +real, parameter :: ALP040 = 5.*SPV050*r1_T0 ! Coefficient of the dSpV_dT fit zt**4 term [m3 kg-1 degC-1] +real, parameter :: ALP140 = 5.*SPV150*r1_T0 ! Coefficient of the dSpV_dT fit zs* * zt**4 term [m3 kg-1 degC-1] +real, parameter :: ALP050 = 6.*SPV060*r1_T0 ! Coefficient of the dSpV_dT fit zt**5 term [m3 kg-1 degC-1] +real, parameter :: ALP001 = SPV011*r1_T0 ! Coefficient of the dSpV_dT fit zp term [m3 kg-1 degC-1] +real, parameter :: ALP101 = SPV111*r1_T0 ! Coefficient of the dSpV_dT fit zs * zp term [m3 kg-1 degC-1] +real, parameter :: ALP201 = SPV211*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zp term [m3 kg-1 degC-1] +real, parameter :: ALP301 = SPV311*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 * zp term [m3 kg-1 degC-1] +real, parameter :: ALP011 = 2.*SPV021*r1_T0 ! Coefficient of the dSpV_dT fit zt * zp term [m3 kg-1 degC-1] +real, parameter :: ALP111 = 2.*SPV121*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt * zp term [m3 kg-1 degC-1] +real, parameter :: ALP211 = 2.*SPV221*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt * zp term [m3 kg-1 degC-1] +real, parameter :: ALP021 = 3.*SPV031*r1_T0 ! Coefficient of the dSpV_dT fit zt**2 * zp term [m3 kg-1 degC-1] +real, parameter :: ALP121 = 3.*SPV131*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt**2 * zp term [m3 kg-1 degC-1] +real, parameter :: ALP031 = 4.*SPV041*r1_T0 ! Coefficient of the dSpV_dT fit zt**3 * zp term [m3 kg-1 degC-1] +real, parameter :: ALP002 = SPV012*r1_T0 ! Coefficient of the dSpV_dT fit zp**2 term [m3 kg-1 degC-1] +real, parameter :: ALP102 = SPV112*r1_T0 ! Coefficient of the dSpV_dT fit zs * zp**2 term [m3 kg-1 degC-1] +real, parameter :: ALP012 = 2.*SPV022*r1_T0 ! Coefficient of the dSpV_dT fit zt * zp**2 term [m3 kg-1 degC-1] +real, parameter :: ALP003 = SPV013*r1_T0 ! Coefficient of the dSpV_dT fit zp**3 term [m3 kg-1 degC-1] + +real, parameter :: BET000 = 0.5*SPV100*r1_S0 ! Constant in the dSpV_dS fit [m3 kg-1 ppt-1] +real, parameter :: BET100 = SPV200*r1_S0 ! Coefficient of the dSpV_dS fit zs term [m3 kg-1 ppt-1] +real, parameter :: BET200 = 1.5*SPV300*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 term [m3 kg-1 ppt-1] +real, parameter :: BET300 = 2.0*SPV400*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 term [m3 kg-1 ppt-1] +real, parameter :: BET400 = 2.5*SPV500*r1_S0 ! Coefficient of the dSpV_dS fit zs**4 term [m3 kg-1 ppt-1] +real, parameter :: BET500 = 3.0*SPV600*r1_S0 ! Coefficient of the dSpV_dS fit zs**5 term [m3 kg-1 ppt-1] +real, parameter :: BET010 = 0.5*SPV110*r1_S0 ! Coefficient of the dSpV_dS fit zt term [m3 kg-1 ppt-1] +real, parameter :: BET110 = SPV210*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt term [m3 kg-1 ppt-1] +real, parameter :: BET210 = 1.5*SPV310*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt term [m3 kg-1 ppt-1] +real, parameter :: BET310 = 2.0*SPV410*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 * zt term [m3 kg-1 ppt-1] +real, parameter :: BET410 = 2.5*SPV510*r1_S0 ! Coefficient of the dSpV_dS fit zs**4 * zt term [m3 kg-1 ppt-1] +real, parameter :: BET020 = 0.5*SPV120*r1_S0 ! Coefficient of the dSpV_dS fit zt**2 term [m3 kg-1 ppt-1] +real, parameter :: BET120 = SPV220*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**2 term [m3 kg-1 ppt-1] +real, parameter :: BET220 = 1.5*SPV320*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt**2 term [m3 kg-1 ppt-1] +real, parameter :: BET320 = 2.0*SPV420*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 * zt**2 term [m3 kg-1 ppt-1] +real, parameter :: BET030 = 0.5*SPV130*r1_S0 ! Coefficient of the dSpV_dS fit zt**3 term [m3 kg-1 ppt-1] +real, parameter :: BET130 = SPV230*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**3 term [m3 kg-1 ppt-1] +real, parameter :: BET230 = 1.5*SPV330*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt**3 term [m3 kg-1 ppt-1] +real, parameter :: BET040 = 0.5*SPV140*r1_S0 ! Coefficient of the dSpV_dS fit zt**4 term [m3 kg-1 ppt-1] +real, parameter :: BET140 = SPV240*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**4 term [m3 kg-1 ppt-1] +real, parameter :: BET050 = 0.5*SPV150*r1_S0 ! Coefficient of the dSpV_dS fit zt**5 term [m3 kg-1 ppt-1] +real, parameter :: BET001 = 0.5*SPV101*r1_S0 ! Coefficient of the dSpV_dS fit zp term [m3 kg-1 ppt-1] +real, parameter :: BET101 = SPV201*r1_S0 ! Coefficient of the dSpV_dS fit zs * zp term [m3 kg-1 ppt-1] +real, parameter :: BET201 = 1.5*SPV301*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zp term [m3 kg-1 ppt-1] +real, parameter :: BET301 = 2.0*SPV401*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 * zp term [m3 kg-1 ppt-1] +real, parameter :: BET011 = 0.5*SPV111*r1_S0 ! Coefficient of the dSpV_dS fit zt * zp term [m3 kg-1 ppt-1] +real, parameter :: BET111 = SPV211*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt * zp term [m3 kg-1 ppt-1] +real, parameter :: BET211 = 1.5*SPV311*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt * zp term [m3 kg-1 ppt-1] +real, parameter :: BET021 = 0.5*SPV121*r1_S0 ! Coefficient of the dSpV_dS fit zt**2 * zp term [m3 kg-1 ppt-1] +real, parameter :: BET121 = SPV221*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**2 * zp term [m3 kg-1 ppt-1] +real, parameter :: BET031 = 0.5*SPV131*r1_S0 ! Coefficient of the dSpV_dS fit zt**3 * zp term [m3 kg-1 ppt-1] +real, parameter :: BET002 = 0.5*SPV102*r1_S0 ! Coefficient of the dSpV_dS fit zp**2 term [m3 kg-1 ppt-1] +real, parameter :: BET102 = SPV202*r1_S0 ! Coefficient of the dSpV_dS fit zs * zp**2 term [m3 kg-1 ppt-1] +real, parameter :: BET012 = 0.5*SPV112*r1_S0 ! Coefficient of the dSpV_dS fit zt * zp**2 term [m3 kg-1 ppt-1] +real, parameter :: BET003 = 0.5*SPV103*r1_S0 ! Coefficient of the dSpV_dS fit zp**3 term [m3 kg-1 ppt-1] +!>@} + +contains + +!> Computes the Roquet et al. in situ specific volume of sea water for scalar inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from absolute salinity (S [g kg-1]), +!! conservative temperature (T [degC]) and pressure [Pa]. It uses the specific volume polynomial +!! fit from Roquet et al. (2015). +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_Roquet_SpV(T, S, pressure, specvol, spv_ref) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: specvol !< In situ specific volume [m3 kg-1] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the absolutes salinity [g kg-1] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: spv0 ! A 1-d array with a copy of the specific volume [m3 kg-1] + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + + call calculate_spec_vol_array_Roquet_SpV(T0, S0, pressure0, spv0, 1, 1, spv_ref) + specvol = spv0(1) + +end subroutine calculate_spec_vol_scalar_Roquet_SpV + +!> Computes the Roquet et al. in situ specific volume of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from absolute salinity (S [g kg-1]), +!! conservative temperature (T [degC]) and pressure [Pa]. It uses the specific volume polynomial +!! fit from Roquet et al. (2015). +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_Roquet_SpV(T, S, pressure, specvol, start, npts, spv_ref) + real, dimension(:), intent(in) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1] + real, dimension(:), intent(in) :: pressure !< pressure [Pa] + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< the number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] + real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] + real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! Specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + integer :: j + + ! The following algorithm was published by Roquet et al. (2015), intended for use in non-Boussinesq ocean models. + do j=start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + if (present(spv_ref)) SV_0S0 = SV_0S0 - spv_ref + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + specvol(j) = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + enddo + +end subroutine calculate_spec_vol_array_Roquet_SpV + + +!> Compute the in situ density of sea water at a point (rho in [kg m-3]) from absolute +!! salinity (S [g kg-1]), conservative temperature (T [degC]) and pressure [Pa], using the +!! specific volume polynomial fit from Roquet et al. (2015). +subroutine calculate_density_scalar_Roquet_SpV(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: spv ! A 1-d array with the specific volume [m3 kg-1] + + T0(1) = T + S0(1) = S + pressure0(1) = pressure + + if (present(rho_ref)) then + call calculate_spec_vol_array_Roquet_SpV(T0, S0, pressure0, spv, 1, 1, spv_ref=1.0/rho_ref) + rho = -rho_ref**2*spv(1) / (rho_ref*spv(1) + 1.0) ! In situ density [kg m-3] + else + call calculate_spec_vol_array_Roquet_SpV(T0, S0, pressure0, spv, 1, 1) + rho = 1.0 / spv(1) + endif + +end subroutine calculate_density_scalar_Roquet_SpV + +!> Compute an array of in situ densities of sea water (rho in [kg m-3]) from absolute +!! salinity (S [g kg-1]), conservative temperature (T [degC]) and pressure [Pa], +!! using the specific volume polynomial fit from Roquet et al. (2015). +subroutine calculate_density_array_Roquet_SpV(T, S, pressure, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real, dimension(size(T)) :: spv ! The specific volume [m3 kg-1] + integer :: j + + if (present(rho_ref)) then + call calculate_spec_vol_array_Roquet_SpV(T, S, pressure, spv, start, npts, spv_ref=1.0/rho_ref) + do j=start,start+npts-1 + rho(j) = -rho_ref**2*spv(j) / (rho_ref*spv(j) + 1.0) ! In situ density [kg m-3] + enddo + else + call calculate_spec_vol_array_Roquet_SpV(T, S, pressure, spv, start, npts) + do j=start,start+npts-1 + rho(j) = 1.0 / spv(j) ! In situ density [kg m-3] + enddo + endif + +end subroutine calculate_density_array_Roquet_SpV + +!> Return the partial derivatives of specific volume with temperature and salinity for 1-d array +!! inputs and outputs, using the specific volume polynomial fit from Roquet et al. (2015). +subroutine calculate_specvol_derivs_Roquet_SpV(T, S, pressure, dSV_dT, dSV_dS, start, npts) + real, intent(in), dimension(:) :: T !< Conservative temperature [degC] + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] + real, intent(in), dimension(:) :: pressure !< Pressure [Pa] + real, intent(inout), dimension(:) :: dSV_dT !< The partial derivative of specific volume with + !! conservative temperature [m3 kg-1 degC-1] + real, intent(inout), dimension(:) :: dSV_dS !< The partial derivative of specific volume with + !! absolute salinity [m3 kg-1 ppt-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] + real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] + real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dSVdzt0 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] + ! from temperature anomalies at the surface pressure + real :: dSVdzt1 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] + ! that is proportional to pressure + real :: dSVdzt2 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] + ! that is proportional to pressure^2 + real :: dSVdzt3 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] + ! that is proportional to pressure^3 + real :: dSVdzs0 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1] from temperature anomalies at the surface pressure + real :: dSVdzs1 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1] proportional to pressure + real :: dSVdzs2 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1] proportional to pressure^2 + real :: dSVdzs3 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1] proportional to pressure^3 + integer :: j + + do j=start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + ! Find the partial derivative of specific volume with temperature + dSVdzt3 = ALP003 + dSVdzt2 = ALP002 + (zs*ALP102 + zt*ALP012) + dSVdzt1 = ALP001 + (zs*(ALP101 + zs*(ALP201 + zs*ALP301)) & + + zt*(ALP011 + (zs*(ALP111 + zs*ALP211) & + + zt*(ALP021 + (zs*ALP121 + zt*ALP031)) )) ) + dSVdzt0 = ALP000 + (zs*(ALP100 + zs*(ALP200 + zs*(ALP300 + zs*(ALP400 + zs*ALP500)))) & + + zt*(ALP010 + (zs*(ALP110 + zs*(ALP210 + zs*(ALP310 + zs*ALP410))) & + + zt*(ALP020 + (zs*(ALP120 + zs*(ALP220 + zs*ALP320)) & + + zt*(ALP030 + (zt*(ALP040 + (zs*ALP140 + zt*ALP050)) & + + zs*(ALP130 + zs*ALP230) )) )) )) ) + + dSV_dT(j) = dSVdzt0 + zp*(dSVdzt1 + zp*(dSVdzt2 + zp*dSVdzt3)) + + ! Find the partial derivative of specific volume with salinity + dSVdzs3 = BET003 + dSVdzs2 = BET002 + (zs*BET102 + zt*BET012) + dSVdzs1 = BET001 + (zs*(BET101 + zs*(BET201 + zs*BET301)) & + + zt*(BET011 + (zs*(BET111 + zs*BET211) & + + zt*(BET021 + (zs*BET121 + zt*BET031)) )) ) + dSVdzs0 = BET000 + (zs*(BET100 + zs*(BET200 + zs*(BET300 + zs*(BET400 + zs*BET500)))) & + + zt*(BET010 + (zs*(BET110 + zs*(BET210 + zs*(BET310 + zs*BET410))) & + + zt*(BET020 + (zs*(BET120 + zs*(BET220 + zs*BET320)) & + + zt*(BET030 + (zt*(BET040 + (zs*BET140 + zt*BET050)) & + + zs*(BET130 + zs*BET230) )) )) )) ) + + ! The division by zs here is because zs = sqrt(S + S0), so dSV_dS = dzs_dS * dSV_dzs = (0.5 / zs) * dSV_dzs + dSV_dS(j) = (dSVdzs0 + zp*(dSVdzs1 + zp*(dSVdzs2 + zp * dSVdzs3))) / zs + enddo + +end subroutine calculate_specvol_derivs_Roquet_SpV + + +!> Compute an array of derivatives of densities of sea water with temperature (drho_dT in [kg m-3 degC-1]) +!! and salinity (drho_dS in [kg m-3 ppt-1]) from absolute salinity (S [g kg-1]), conservative temperature +!! (T [degC]) and pressure [Pa], using the specific volume polynomial fit from Roquet et al. (2015). +subroutine calculate_density_derivs_array_Roquet_SpV(T, S, pressure, drho_dT, drho_dS, start, npts) + real, intent(in), dimension(:) :: T !< Conservative temperature [degC] + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] + real, intent(in), dimension(:) :: pressure !< pressure [Pa] + real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with + !! conservative temperature [kg m-3 degC-1] + real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with + !! absolute salinity [kg m-3 ppt-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + real, dimension(size(T)) :: specvol ! The specific volume [m3 kg-1] + real, dimension(size(T)) :: dSV_dT ! The partial derivative of specific volume with + ! conservative temperature [m3 kg-1 degC-1] + real, dimension(size(T)) :: dSV_dS ! The partial derivative of specific volume with + ! absolute salinity [m3 kg-1 ppt-1] + real :: rho ! The in situ density [kg m-3] + integer :: j + + call calculate_spec_vol_array_Roquet_SpV(T, S, pressure, specvol, start, npts) + call calculate_specvol_derivs_Roquet_SpV(T, S, pressure, dSV_dT, dSV_dS, start, npts) + + do j=start,start+npts-1 + rho = 1.0 / specvol(j) + drho_dT(j) = -dSv_dT(j) * rho**2 + drho_dS(j) = -dSv_dS(j) * rho**2 + enddo + +end subroutine calculate_density_derivs_array_Roquet_SpV + +!> Wrapper to calculate_density_derivs_array_Roquet_SpV for scalar inputs +subroutine calculate_density_derivs_scalar_Roquet_SpV(T, S, pressure, drho_dt, drho_ds) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with + !! conservative temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with + !! absolute salinity [kg m-3 ppt-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdt0 ! A 1-d array with a copy of the derivative of density + ! with conservative temperature [kg m-3 degC-1] + real, dimension(1) :: drds0 ! A 1-d array with a copy of the derivative of density + ! with absolute salinity [kg m-3 ppt-1] + + T0(1) = T + S0(1) = S + pressure0(1) = pressure + + call calculate_density_derivs_array_Roquet_SpV(T0, S0, pressure0, drdt0, drds0, 1, 1) + drho_dt = drdt0(1) + drho_ds = drds0(1) +end subroutine calculate_density_derivs_scalar_Roquet_SpV + +!> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility +!! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), +!! conservative temperature (T [degC]), and pressure [Pa], using the specific volume +!! polynomial fit from Roquet et al. (2015). +subroutine calculate_compress_Roquet_SpV(T, S, pressure, rho, drho_dp, start, npts) + real, intent(in), dimension(:) :: T !< Conservative temperature [degC] + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] + real, intent(in), dimension(:) :: pressure !< pressure [Pa] + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3] + real, intent(out), dimension(:) :: 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 !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: zp ! Pressure normalized by an assumed pressure range [nondim] + real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dSV_00p_dp ! Derivative of the pressure-dependent reference specific volume profile with + ! normalized pressure [m3 kg-1] + real :: dSV_TS_dp ! Derivative of the specific volume anomaly from the reference profile with + ! normalized pressure [m3 kg-1] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + real :: dSpecVol_dp ! The partial derivative of specific volume with pressure [m3 kg-1 Pa-1] + integer :: j + + ! The following algorithm was published by Roquet et al. (2015), intended for use + ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. + do j=start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + ! specvol = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + rho(j) = 1.0 / (SV_TS + SV_00p) ! In situ density [kg m-3] + + dSV_00p_dp = V00 + zp*(2.*V01 + zp*(3.*V02 + zp*(4.*V03 + zp*(5.*V04 + zp*(6.*V05))))) + dSV_TS_dp = SV_TS1 + zp*(2.*SV_TS2 + zp*(3.*SV_TS3)) + dSpecVol_dp = (dSV_TS_dp + dSV_00p_dp) * (Pa2db*r1_P0) ! [m3 kg-1 Pa-1] + drho_dp(j) = -dSpecVol_dp * rho(j)**2 ! Compressibility [s2 m-2] + + enddo +end subroutine calculate_compress_Roquet_SpV + + +!> Second derivatives of specific volume with respect to temperature, salinity, and pressure for a +!! 1-d array inputs and outputs using the specific volume polynomial fit from Roquet et al. (2015). +subroutine calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, & + dSV_ds_dp, dSV_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in ) :: S !< Absolute salinity [g kg-1] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: dSV_ds_ds !< Second derivative of specific volume with respect + !! to salinity [m3 kg-1 ppt-2] + real, dimension(:), intent(inout) :: dSV_ds_dt !< Second derivative of specific volume with respect + !! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dt_dt !< Second derivative of specific volume with respect + !! to temperature [m3 kg-1 degC-2] + real, dimension(:), intent(inout) :: dSV_ds_dp !< Second derivative of specific volume with respect to pressure + !! and salinity [m3 kg-1 ppt-1 Pa-1] + real, dimension(:), intent(inout) :: dSV_dt_dp !< Second derivative of specific volume with respect to pressure + !! and temperature [m3 kg-1 degC-1 Pa-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + + ! Local variables + real :: zp ! Pressure normalized by an assumed pressure range [nondim] + real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: I_s ! The inverse of zs [nondim] + real :: d2SV_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] + real :: d2SV_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] + real :: d2SV_p2 ! A contribution to one of the second derivatives that is proportional to pressure^2 [various] + real :: d2SV_p3 ! A contribution to one of the second derivatives that is proportional to pressure^3 [various] + integer :: j + + do j = start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = P(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + I_s = 1.0 / zs + + ! Find dSV_ds_ds + d2SV_p3 = -SPV103*I_s**2 + d2SV_p2 = -(SPV102 + zt*SPV112)*I_s**2 + d2SV_p1 = (3.*SPV301 + (zt*(3.*SPV311) + zs*(8.*SPV401))) & + - ( SPV101 + zt*(SPV111 + zt*(SPV121 + zt*SPV131)) )*I_s**2 + d2SV_p0 = (3.*SPV300 + (zs*(8.*SPV400 + zs*(15.*SPV500 + zs*(24.*SPV600))) & + + zt*(3.*SPV310 + (zs*(8.*SPV410 + zs*(15.*SPV510)) & + + zt*(3.*SPV320 + (zs*(8.*SPV420) + zt*(3.*SPV330))) )) )) & + - (SPV100 + zt*(SPV110 + zt*(SPV120 + zt*(SPV130 + zt*(SPV140 + zt*SPV150)))) )*I_s**2 + dSV_dS_dS(j) = (0.5*r1_S0)**2 * ((d2SV_p0 + zp*(d2SV_p1 + zp*(d2SV_p2 + zp*d2SV_p3))) * I_s) + + ! Find dSV_ds_dt + d2SV_p2 = SPV112 + d2SV_p1 = SPV111 + (zs*(2.*SPV211 + zs*(3.*SPV311)) & + + zt*(2.*SPV121 + (zs*(4.*SPV221) + zt*(3.*SPV131))) ) + d2SV_p0 = SPV110 + (zs*(2.*SPV210 + zs*(3.*SPV310 + zs*(4.*SPV410 + zs*(5.*SPV510)))) & + + zt*(2.*SPV120 + (zs*(4.*SPV220 + zs*(6.*SPV320 + zs*(8.*SPV420))) & + + zt*(3.*SPV130 + (zs*(6.*SPV230 + zs*(9.*SPV330)) & + + zt*(4.*SPV140 + (zs*(8.*SPV240) & + + zt*(5.*SPV150))) )) )) ) + dSV_ds_dt(j) = (0.5*r1_S0*r1_T0) * ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) + + ! Find dSV_dt_dt + d2SV_p2 = 2.*SPV022 + d2SV_p1 = 2.*SPV021 + (zs*(2.*SPV121 + zs*(2.*SPV221)) & + + zt*(6.*SPV031 + (zs*(6.*SPV131) + zt*(12.*SPV041))) ) + d2SV_p0 = 2.*SPV020 + (zs*(2.*SPV120 + zs*( 2.*SPV220 + zs*( 2.*SPV320 + zs * (2.*SPV420)))) & + + zt*(6.*SPV030 + (zs*( 6.*SPV130 + zs*( 6.*SPV230 + zs * (6.*SPV330))) & + + zt*(12.*SPV040 + (zs*(12.*SPV140 + zs *(12.*SPV240)) & + + zt*(20.*SPV050 + (zs*(20.*SPV150) & + + zt*(30.*SPV060) )) )) )) ) + dSV_dt_dt(j) = (d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * r1_T0**2 + + ! Find dSV_ds_dp + d2SV_p2 = 3.*SPV103 + d2SV_p1 = 2.*SPV102 + (zs*(4.*SPV202) + zt*(2.*SPV112)) + d2SV_p0 = SPV101 + (zs*(2.*SPV201 + zs*(3.*SPV301 + zs*(4.*SPV401))) & + + zt*(SPV111 + (zs*(2.*SPV211 + zs*(3.*SPV311)) & + + zt*( SPV121 + (zs*(2.*SPV221) + zt*SPV131)) )) ) + dSV_ds_dp(j) = ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) * (0.5*r1_S0 * Pa2db*r1_P0) + + ! Find dSV_dt_dp + d2SV_p2 = 3.*SPV013 + d2SV_p1 = 2.*SPV012 + (zs*(2.*SPV112) + zt*(4.*SPV022)) + d2SV_p0 = SPV011 + (zs*(SPV111 + zs*( SPV211 + zs* SPV311)) & + + zt*(2.*SPV021 + (zs*(2.*SPV121 + zs*(2.*SPV221)) & + + zt*(3.*SPV031 + (zs*(3.*SPV131) + zt*(4.*SPV041))) )) ) + dSV_dt_dp(j) = (d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * (Pa2db*r1_P0* r1_T0) + enddo + +end subroutine calc_spec_vol_second_derivs_array_Roquet_SpV + + +!> Second derivatives of density with respect to temperature, salinity, and pressure for a +!! 1-d array inputs and outputs using the specific volume polynomial fit from Roquet et al. (2015). +subroutine calculate_density_second_derivs_array_Roquet_SpV(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in ) :: S !< Absolute salinity [g kg-1] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_ds_ds !< Second derivative of density with respect + !! to salinity [kg m-3 ppt-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Second derivative of density with respect + !! to salinity and temperature [kg m-3 ppt-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Second derivative of density with respect + !! to temperature [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Second derivative of density with respect to pressure + !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Second derivative of density with respect to pressure + !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + + ! Local variables + real, dimension(size(T)) :: rho ! The in situ density [kg m-3] + real, dimension(size(T)) :: drho_dp ! The partial derivative of density with pressure + ! (also the inverse of the square of sound speed) [s2 m-2] + real, dimension(size(T)) :: dSV_dT ! The partial derivative of specific volume with + ! conservative temperature [m3 kg-1 degC-1] + real, dimension(size(T)) :: dSV_dS ! The partial derivative of specific volume with + ! absolute salinity [m3 kg-1 ppt-1] + real, dimension(size(T)) :: dSV_ds_ds ! Second derivative of specific volume with respect + ! to salinity [m3 kg-1 ppt-2] + real, dimension(size(T)) :: dSV_ds_dt ! Second derivative of specific volume with respect + ! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real, dimension(size(T)) :: dSV_dt_dt ! Second derivative of specific volume with respect + ! to temperature [m3 kg-1 degC-2] + real, dimension(size(T)) :: dSV_ds_dp ! Second derivative of specific volume with respect to pressure + ! and salinity [m3 kg-1 ppt-1 Pa-1] + real, dimension(size(T)) :: dSV_dt_dp ! Second derivative of specific volume with respect to pressure + ! and temperature [m3 kg-1 degC-1 Pa-1] + integer :: j + + call calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, & + dSV_ds_dp, dSV_dt_dp, start, npts) + call calculate_specvol_derivs_Roquet_SpV(T, S, P, dSV_dT, dSV_dS, start, npts) + call calculate_compress_Roquet_SpV(T, S, P, rho, drho_dp, start, npts) + + do j = start,start+npts-1 + ! Find drho_ds_ds + drho_dS_dS(j) = rho(j)**2 * (2.0*rho(j)*dSV_dS(j)**2 - dSV_dS_dS(j)) + + ! Find drho_ds_dt + drho_ds_dt(j) = rho(j)**2 * (2.0*rho(j)*(dSV_dT(j)*dSV_dS(j)) - dSV_dS_dT(j)) + + ! Find drho_dt_dt + drho_dT_dT(j) = rho(j)**2 * (2.0*rho(j)*dSV_dT(j)**2 - dSV_dT_dT(j)) + + ! Find drho_ds_dp + drho_ds_dp(j) = -rho(j) * (2.0*dSV_dS(j) * drho_dp(j) + rho(j) * dSV_dS_dp(j)) + + ! Find drho_dt_dp + drho_dt_dp(j) = -rho(j) * (2.0*dSV_dT(j) * drho_dp(j) + rho(j) * dSV_dT_dp(j)) + enddo + +end subroutine calculate_density_second_derivs_array_Roquet_SpV + +!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. +!! +!! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar +subroutine calculate_density_second_derivs_scalar_Roquet_SpV(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Conservative temperature [degC] + real, intent(in ) :: S !< Absolute salinity [g kg-1] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Second derivative of density with respect + !! to salinity [kg m-3 ppt-2] + real, intent( out) :: drho_ds_dt !< Second derivative of density with respect + !! to salinity and temperature [kg m-3 ppt-1 degC-1] + real, intent( out) :: drho_dt_dt !< Second derivative of density with respect + !! to temperature [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Second derivative of density with respect to pressure + !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, intent( out) :: drho_dt_dp !< Second derivative of density with respect to pressure + !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [g kg-1] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 ppt-2] + real, dimension(1) :: drdsdt ! The second derivative of density with salinity and + ! temperature [kg m-3 ppt-1 degC-1] + real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] + real, dimension(1) :: drdsdp ! The second derivative of density with salinity and + ! pressure [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, dimension(1) :: drdtdp ! The second derivative of density with temperature and + ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + T0(1) = T + S0(1) = S + P0(1) = P + call calculate_density_second_derivs_array_Roquet_SpV(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + drho_ds_ds = drdsds(1) + drho_ds_dt = drdsdt(1) + drho_dt_dt = drdtdt(1) + drho_ds_dp = drdsdp(1) + drho_dt_dp = drdtdp(1) + +end subroutine calculate_density_second_derivs_scalar_Roquet_SpV + +!> \namespace mom_eos_Roquet_SpV +!! +!! \section section_EOS_Roquet_SpV NEMO equation of state +!! +!! Fabien Roquet and colleagues developed this equation of state using a simple polynomial fit +!! to the TEOS-10 equation of state expressions for specific, for efficiency when used with a +!! non-Boussinesq ocean model. This particular equation of state is a balance between an +!! accuracy that matches the TEOS-10 density to better than observational uncertainty with a +!! polynomial form that can be evaluated quickly despite having 55 terms. +!! +!! \subsection section_EOS_Roquet_Spv_references References +!! +!! Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015: +!! Accurate polynomial expressions for the density and specific volume +!! of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. + +end module MOM_EOS_Roquet_Spv From b5b69e721154e09d4a203803b19a638246413f9b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Mar 2023 14:31:36 -0500 Subject: [PATCH 56/91] +Add MOM_EOS_Jackett06.F90 Added the new equation of state module MOM_EOS_Jackett06 with the rational function equation of state from Jackett et al. (2006). This uses potential temperature and practical salinity as state variables, but with a fit to more up-to-date observational data than Wright (1997) or UNESCO / Jackett and McDougall (1995). This equation of state has also been added to MOM_EOS, where it is enabled by setting EQN_OF_STATE="JACKETT_06". The EoS unit tests are being called for the new equation of state (it passes). This commit also adds slightly more output from successful EoS unit tests when run with typical levels of verbosity. By default, all answers are bitwise identical, but there are numerous new publicly visible interfaces. --- src/equation_of_state/MOM_EOS.F90 | 116 +++- src/equation_of_state/MOM_EOS_Jackett06.F90 | 561 ++++++++++++++++++++ 2 files changed, 649 insertions(+), 28 deletions(-) create mode 100644 src/equation_of_state/MOM_EOS_Jackett06.F90 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index bd5965907c..1640fb6e0e 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -23,23 +23,21 @@ module MOM_EOS use MOM_EOS_Wright_red, only : calculate_specvol_derivs_wright_red, int_density_dz_wright_red use MOM_EOS_Wright_red, only : calculate_compress_wright_red, int_spec_vol_dp_wright_red use MOM_EOS_Wright_red, only : calculate_density_second_derivs_wright_red +use MOM_EOS_Jackett06, only : calculate_density_Jackett06, calculate_spec_vol_Jackett06 +use MOM_EOS_Jackett06, only : calculate_density_derivs_Jackett06, calculate_specvol_derivs_Jackett06 +use MOM_EOS_Jackett06, only : calculate_compress_Jackett06, calculate_density_second_derivs_Jackett06 use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco -use MOM_EOS_UNESCO, only : calculate_density_second_derivs_UNESCO -use MOM_EOS_UNESCO, only : calculate_compress_unesco +use MOM_EOS_UNESCO, only : calculate_density_second_derivs_UNESCO, calculate_compress_unesco use MOM_EOS_NEMO, only : calculate_density_nemo use MOM_EOS_NEMO, only : calculate_density_derivs_nemo -use MOM_EOS_NEMO, only : calculate_density_second_derivs_NEMO -use MOM_EOS_NEMO, only : calculate_compress_nemo +use MOM_EOS_NEMO, only : calculate_density_second_derivs_NEMO, calculate_compress_nemo use MOM_EOS_Roquet_SpV, only : calculate_density_Roquet_SpV, calculate_spec_vol_Roquet_SpV use MOM_EOS_Roquet_SpV, only : calculate_density_derivs_Roquet_SpV, calculate_specvol_derivs_Roquet_SpV -use MOM_EOS_Roquet_SpV, only : calculate_compress_Roquet_SpV -use MOM_EOS_Roquet_SpV, only : calculate_density_second_derivs_Roquet_SpV +use MOM_EOS_Roquet_SpV, only : calculate_compress_Roquet_SpV, calculate_density_second_derivs_Roquet_SpV use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 -use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_compress_teos10 +use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10, calculate_specvol_derivs_teos10 +use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10, calculate_compress_teos10 use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero use MOM_TFreeze, only : calculate_TFreeze_teos10 @@ -174,6 +172,7 @@ module MOM_EOS integer, parameter, public :: EOS_TEOS10 = 6 !< A named integer specifying an equation of state integer, parameter, public :: EOS_NEMO = 7 !< A named integer specifying an equation of state integer, parameter, public :: EOS_ROQUET_SPV = 8 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_JACKETT06 = 9 !< A named integer specifying an equation of state character*(12), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state character*(12), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state @@ -185,6 +184,7 @@ module MOM_EOS character*(12), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state character*(12), parameter :: EOS_ROQUET_RHO_STRING = "ROQUET_RHO" !< A string for specifying the equation of state character*(12), parameter :: EOS_ROQUET_SPV_STRING = "ROQUET_SPV" !< A string for specifying the equation of state +character*(12), parameter :: EOS_JACKETT06_STRING = "JACKETT_06" !< A string for specifying the equation of state character*(12), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression @@ -295,6 +295,9 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) + case (EOS_JACKETT06) + call calculate_density_second_derivs_Jackett06(T_scale*T, S_scale*S, p_scale*pressure, & + d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case default call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") end select @@ -341,6 +344,8 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) case (EOS_ROQUET_SPV) call calculate_density_Roquet_SpV(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_JACKETT06) + call calculate_density_Jackett06(T, S, pressure, rho, start, npts, rho_ref) case default call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") end select @@ -418,6 +423,10 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_JACKETT06) + call calculate_density_Jackett06(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_Jackett06(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) case default call MOM_error(FATAL, "calculate_stanley_density_array: EOS%form_of_EOS is not valid.") end select @@ -582,6 +591,10 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, call calculate_density_teos10(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_teos10(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) + case (EOS_JACKETT06) + call calculate_density_Jackett06(Ta, Sa, pres, rho, is, npts, rho_reference) + call calculate_density_second_derivs_Jackett06(Ta, Sa, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, is, npts) case default call MOM_error(FATAL, "calculate_stanley_density_1d: EOS is not valid.") end select @@ -641,6 +654,8 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s endif case (EOS_ROQUET_SpV) call calculate_spec_vol_Roquet_SpV(T, S, pressure, specvol, start, npts, spv_ref) + case (EOS_JACKETT06) + call calculate_spec_vol_Jackett06(T, S, pressure, specvol, start, npts, spv_ref) case default call MOM_error(FATAL, "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") end select @@ -929,6 +944,8 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_ROQUET_SPV) call calculate_density_derivs_Roquet_SpV(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_JACKETT06) + call calculate_density_derivs_Jackett06(T, S, pressure, drho_dT, drho_dS, start, npts) case default call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") end select @@ -1034,6 +1051,8 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS call calculate_density_derivs_wright_red(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) case (EOS_TEOS10) call calculate_density_derivs_teos10(Ta(1), Sa(1), pres(1), drho_dT, drho_dS) + case (EOS_JACKETT06) + call calculate_density_derivs_Jackett06(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) case default ! Some equations of state do not have a scalar form of calculate_density_derivs, so try the array form. call calculate_density_derivs_array(Ta, Sa, pres, dR_dT, dR_dS, 1, 1, EOS) @@ -1116,6 +1135,9 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_TEOS10) call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_JACKETT06) + call calculate_density_second_derivs_Jackett06(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case default call MOM_error(FATAL, "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") end select @@ -1155,6 +1177,9 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + case (EOS_JACKETT06) + call calculate_density_second_derivs_Jackett06(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case default call MOM_error(FATAL, "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") end select @@ -1248,6 +1273,9 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr case (EOS_TEOS10) call calculate_density_second_derivs_teos10(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) + case (EOS_JACKETT06) + call calculate_density_second_derivs_Jackett06(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case default call MOM_error(FATAL, "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") end select @@ -1328,6 +1356,8 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start enddo case (EOS_ROQUET_SPV) call calculate_specvol_derivs_Roquet_SpV(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_JACKETT06) + call calculate_specvol_derivs_Jackett06(T, S, pressure, dSV_dT, dSV_dS, start, npts) case default call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") end select @@ -1438,6 +1468,8 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) call calculate_compress_nemo(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_ROQUET_SpV) call calculate_compress_Roquet_SpV(Ta, Sa, pres, rho, drho_dp, is, npts) + case (EOS_JACKETT06) + call calculate_compress_Jackett06(Ta, Sa, pres, rho, drho_dp, is, npts) case default call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") end select @@ -1747,6 +1779,8 @@ subroutine EOS_init(param_file, EOS, US) EOS%form_of_EOS = EOS_NEMO case (EOS_ROQUET_SPV_STRING) EOS%form_of_EOS = EOS_ROQUET_SPV + case (EOS_JACKETT06_STRING) + EOS%form_of_EOS = EOS_JACKETT06 case default call MOM_error(FATAL, "interpret_eos_selection: EQN_OF_STATE "//& trim(tmpstr) // " in input file is invalid.") @@ -2108,6 +2142,12 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_JACKETT06) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "JACKETT06", & + rho_check=1027.539690758425*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "JACKETT06 EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + ! The TEOS10 equation of state is not passing the self consistency tests for dho_dS_dp due ! to a bug (a missing division by the square root of salinity) on line 109 of ! pkg/GSW-Fortan/toolbox/gsw_specvol_second_derivatives.f90. This bug has been highlighted in an @@ -2278,30 +2318,50 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, EOS) call calculate_compress(T(0,0,0), S(0,0,0), p(0,0,0), rho_tmp, drho_dp, EOS) + OK = .true. + tol = 1000.0*epsilon(tol) + + ! Check that the density agrees with the provided check value + if (present(rho_check)) then + test_OK = (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) + OK = OK .and. test_OK + if (verbose) then + write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & + rho_ref+rho(0,0,0,1), rho_check, (rho_ref+rho(0,0,0,1))-rho_check, tol*rho(0,0,0,1) + if (test_OK) then + call MOM_mesg(trim(EOS_name)//" rho agrees with its check value :"//trim(mesg)) + else + call MOM_error(WARNING, trim(EOS_name)//" rho disagrees with its check value :"//trim(mesg)) + endif + endif + endif + + ! Check that the specific volume agrees with the provided check value or the inverse of density if (present(spv_check)) then - OK = (abs(spv_check - (spv_ref + spv(0,0,0,1))) < tol*abs(spv_ref + spv(0,0,0,1))) - if (verbose .and. .not.OK) then - write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & - spv_check, spv_ref+spv(0,0,0,1), tol*spv(0,0,0,1) - call MOM_error(WARNING, "The value of "//trim(EOS_name)//" spv disagrees with its check value :"//trim(mesg)) + test_OK = (abs(spv_check - (spv_ref + spv(0,0,0,1))) < tol*abs(spv_ref + spv(0,0,0,1))) + OK = OK .and. test_OK + if (verbose) then + write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & + spv_ref+spv(0,0,0,1), spv_check, spv_ref+spv(0,0,0,1)-spv_check, tol*spv(0,0,0,1) + if (test_OK) then + call MOM_mesg(trim(EOS_name)//" spv agrees with its check value :"//trim(mesg)) + else + call MOM_error(WARNING, trim(EOS_name)//" spv disagrees with its check value :"//trim(mesg)) + endif endif else - OK = (abs((rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0) < tol) - if (verbose .and. .not.OK) then + test_OK = (abs((rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0) < tol) + OK = OK .and. test_OK + if (verbose) then write(mesg, '(ES16.8," and ",ES16.8,", ratio - 1 = ",ES16.8)') & - rho(0,0,0,1), 1.0/(spv_ref + spv(0,0,0,1)) - rho_ref, & + rho_ref+rho(0,0,0,1), 1.0/(spv_ref + spv(0,0,0,1)), & (rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0 - call MOM_error(WARNING, "The values of "//trim(EOS_name)//" rho and 1/spv disagree. "//trim(mesg)) - endif - endif - if (present(rho_check)) then - test_OK = (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) - OK = OK .and. test_OK - if (verbose .and. .not.test_OK) then - write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & - rho_check, rho_ref+rho(0,0,0,1), tol*rho(0,0,0,1) - call MOM_error(WARNING, "The value of "//trim(EOS_name)//" rho disagrees with its check value :"//trim(mesg)) + if (test_OK) then + call MOM_mesg("The values of "//trim(EOS_name)//" rho and 1/spv agree. "//trim(mesg)) + else + call MOM_error(WARNING, "The values of "//trim(EOS_name)//" rho and 1/spv disagree. "//trim(mesg)) + endif endif endif diff --git a/src/equation_of_state/MOM_EOS_Jackett06.F90 b/src/equation_of_state/MOM_EOS_Jackett06.F90 new file mode 100644 index 0000000000..3d13591bb8 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Jackett06.F90 @@ -0,0 +1,561 @@ +!> The equation of state using the Jackett et al 2006 expressions that are often used in Hycom +module MOM_EOS_Jackett06 + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public calculate_compress_Jackett06, calculate_density_Jackett06, calculate_spec_vol_Jackett06 +public calculate_density_derivs_Jackett06, calculate_specvol_derivs_Jackett06 +public calculate_density_second_derivs_Jackett06 + +!> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to +!! a reference density, from salinity in practical salinity units ([PSU]), potential +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! Jackett et al., 2006, J. Atmos. Ocean. Tech., 32, 1709-1728. +interface calculate_density_Jackett06 + module procedure calculate_density_scalar_Jackett, calculate_density_array_Jackett +end interface calculate_density_Jackett06 + +!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect +!! to a reference specific volume, from salinity in practical salinity units ([PSU]), potential +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! Jackett et al., 2006, J. Atmos. Ocean. Tech., 32, 1709-1728. +interface calculate_spec_vol_Jackett06 + module procedure calculate_spec_vol_scalar_Jackett, calculate_spec_vol_array_Jackett +end interface calculate_spec_vol_Jackett06 + +!> Compute the derivatives of density with temperature and salinity +interface calculate_density_derivs_Jackett06 + module procedure calculate_density_derivs_scalar_Jackett, calculate_density_derivs_array_Jackett +end interface calculate_density_derivs_Jackett06 + +!> Compute the second derivatives of density with various combinations +!! of temperature, salinity, and pressure +interface calculate_density_second_derivs_Jackett06 + module procedure calculate_density_second_derivs_scalar_Jackett, calculate_density_second_derivs_array_Jackett +end interface calculate_density_second_derivs_Jackett06 + +!>@{ Parameters in the Jackett et al. equation of state, which is a fit to the Fiestel (2003) +! equation of state for the range: -2 < theta < 40 [degC], 0 < S < 42 [PSU], 0 < p < 1e8 [Pa]. +! The notation here is for terms in the numerator of the expression for density of +! RNabc for terms proportional to S**a * T**b * P**c, and terms in the denominator as RDabc. +! For terms proportional to S**1.5, 6 is used in this notation. + +! --- coefficients for 25-term rational function sigloc(). +real, parameter :: & + RN000 = 9.9984085444849347d+02, & ! Density numerator constant coefficient [kg m-3] + RN001 = 1.1798263740430364d-06, & ! Density numerator P coefficient [kg m-3 Pa-1] + RN002 = -2.5862187075154352d-16, & ! Density numerator P^2 coefficient [kg m-3 Pa-2] + RN010 = 7.3471625860981584d+00, & ! Density numerator T coefficient [kg m-3 degC-1] + RN020 = -5.3211231792841769d-02, & ! Density numerator T^2 coefficient [kg m-3 degC-2] + RN021 = 9.8920219266399117d-12, & ! Density numerator T^2 P coefficient [kg m-3 degC-2 Pa-1] + RN022 = -3.2921414007960662d-20, & ! Density numerator T^2 P^2 coefficient [kg m-3 degC-2 Pa-2] + RN030 = 3.6492439109814549d-04, & ! Density numerator T^3 coefficient [kg m-3 degC-3] + RN100 = 2.5880571023991390d+00, & ! Density numerator S coefficient [kg m-3 PSU-1] + RN101 = 4.6996642771754730d-10, & ! Density numerator S P coefficient [kg m-3 PSU-1 Pa-1] + RN110 = -6.7168282786692355d-03, & ! Density numerator S T coefficient [kg m-3 degC-1 PSU-1] + RN200 = 1.9203202055760151d-03, & ! Density numerator S^2 coefficient [kg m-3] + + RD001 = 6.7103246285651894d-10, & ! Density denominator P coefficient [Pa-1] + RD010 = 7.2815210113327091d-03, & ! Density denominator T coefficient [degC-1] + RD013 = -9.1534417604289062d-30, & ! Density denominator T P^3 coefficient [degC-1 Pa-3] + RD020 = -4.4787265461983921d-05, & ! Density denominator T^2 coefficient [degC-2] + RD030 = 3.3851002965802430d-07, & ! Density denominator T^3 coefficient [degC-3] + RD032 = -2.4461698007024582d-25, & ! Density denominator T^3 P^2 coefficient [degC-3 Pa-2] + RD040 = 1.3651202389758572d-10, & ! Density denominator T^4 coefficient [degC-4] + RD100 = 1.7632126669040377d-03, & ! Density denominator S coefficient [PSU-1] + RD110 = -8.8066583251206474d-06, & ! Density denominator S T coefficient [degC-1 PSU-1] + RD130 = -1.8832689434804897d-10, & ! Density denominator S T^3 coefficient [degC-3 PSU-1] + RD600 = 5.7463776745432097d-06, & ! Density denominator S^1.5 coefficient [PSU-1.5] + RD620 = 1.4716275472242334d-09 ! Density denominator S^1.5 T^2 coefficient [degC-2 PSU-1.5] +!>@} + +contains + +!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Jackett et al., 2006, J. Atmos. Ocean. Tech., 32, 1709-1728. +subroutine calculate_density_array_Jackett(T, S, pres, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: pres !< Pressure [Pa]. + real, dimension(:), intent(inout) :: rho !< In situ density [kg m-3]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + real :: rho0 ! The surface density of fresh water at 0 degC, perhaps less the refernce density [kg m-3] + integer :: j + + do j=start,start+npts-1 + S1_2 = sqrt(max(0.0,s(j))) + T2 = T(j)*T(j) + + num_STP = (T(j)*(RN010 + T(j)*(RN020 + T(j)*RN030)) + & + S(j)*(RN100 + (T(j)*RN110 + S(j)*RN200)) ) + & + pres(j)*(RN001 + ((T2*RN021 + S(j)*RN101) + pres(j)*(RN002 + T2*RN022))) + den = 1.0 + ((T(j)*(RD010 + T(j)*(RD020 + T(j)*(RD030 + T(j)* RD040))) + & + S(j)*(RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pres(j)*(RD001 + pres(j)*T(j)*(T2*RD032 + pres(j)*RD013)) ) + I_den = 1.0 / den + + rho0 = RN000 + if (present(rho_ref)) rho0 = RN000 - rho_ref*den + + rho(j) = (rho0 + num_STP)*I_den + enddo + +end subroutine calculate_density_array_Jackett + +!> Computes the Jackett et al. in situ specific volume of sea water for 1-d array inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Jackett et al., 2006, J. Atmos. Ocean. Tech., 32, 1709-1728. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_Jackett(T, S, pres, specvol, start, npts, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the + !! surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pres !< pressure [Pa]. + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [m3 kg-1]. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density (not specific volume) [kg m-3] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density (not specific volume) [nondim] + real :: I_num ! The inverse of the numerator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + integer :: j + + do j=start,start+npts-1 + S1_2 = sqrt(max(0.0,s(j))) + T2 = T(j)*T(j) + + num_STP = (T(j)*(RN010 + T(j)*(RN020 + T(j)*RN030)) + & + S(j)*(RN100 + (T(j)*RN110 + S(j)*RN200)) ) + & + pres(j)*(RN001 + ((T2*RN021 + S(j)*RN101) + pres(j)*(RN002 + T2*RN022))) + den_STP = (T(j)*(RD010 + T(j)*(RD020 + T(j)*(RD030 + T(j)* RD040))) + & + S(j)*(RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pres(j)*(RD001 + pres(j)*T(j)*(T2*RD032 + pres(j)*RD013)) + I_num = 1.0 / (RN000 + num_STP) + if (present(spv_ref)) then + ! This form is slightly more complicated, but it cancels the leading terms better. + specvol(j) = ((1.0 - spv_ref*RN000) + (den_STP - spv_ref*num_STP)) * I_num + else + specvol(j) = (1.0 + den_STP) * I_num + endif + enddo + +end subroutine calculate_spec_vol_array_Jackett + +!> Return the thermal/haline expansion coefficients for 1-d array inputs and outputs +subroutine calculate_density_derivs_array_Jackett(T, S, pres, drho_dT, drho_dS, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the + !! surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pres !< pressure [Pa]. + real, intent(inout), dimension(:) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(inout), dimension(:) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_denom2 ! The inverse of the square of the denominator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + integer :: j + + do j=start,start+npts-1 + S1_2 = sqrt(max(0.0,s(j))) + T2 = T(j)*T(j) + + num = RN000 + ((T(j)*(RN010 + T(j)*(RN020 + T(j)*RN030)) + & + S(j)*(RN100 + (T(j)*RN110 + S(j)*RN200)) ) + & + pres(j)*(RN001 + ((T2*RN021 + S(j)*RN101) + pres(j)*(RN002 + T2*RN022))) ) + den = 1.0 + ((T(j)*(RD010 + T(j)*(RD020 + T(j)*(RD030 + T(j)* RD040))) + & + S(j)*(RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pres(j)*(RD001 + pres(j)*T(j)*(T2*RD032 + pres(j)*RD013)) ) + + dnum_dT = ((RN010 + T(j)*(2.*RN020 + T(j)*(3.*RN030))) + S(j)*RN110) + & + pres(j)*T(j)*(2.*RN021 + pres(j)*(2.*RN022)) + dnum_dS = (RN100 + (T(j)*RN110 + S(j)*(2.*RN200))) + pres(j)*RN101 + dden_dT = ((RD010 + T(j)*((2.*RD020) + T(j)*((3.*RD030) + T(j)*(4.*RD040)))) + & + S(j)*((RD110 + T2*(3.*RD130)) + S1_2*T(j)*(2.*RD620)) ) + & + pres(j)**2*(T2*3.*RD032 + pres(j)*RD013) + dden_dS = RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_denom2 = 1.0 / den**2 + + ! rho(j) = num / den + drho_dT(j) = (dnum_dT * den - num * dden_dT) * I_denom2 + drho_dS(j) = (dnum_dS * den - num * dden_dS) * I_denom2 + enddo + +end subroutine calculate_density_derivs_array_Jackett + +!> Return the partial derivatives of specific volume with temperature and salinity +!! for 1-d array inputs and outputs +subroutine calculate_specvol_derivs_Jackett06(T, S, pres, dSV_dT, dSV_dS, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pres !< Pressure [Pa]. + real, intent(inout), dimension(:) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1]. + real, intent(inout), dimension(:) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: num ! Numerator of the rational expresion for density (not specific volume) [kg m-3] + real :: den ! Denominator of the rational expresion for density (not specific volume) [nondim] + real :: I_num2 ! The inverse of the square of the numerator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + integer :: j + + do j=start,start+npts-1 + S1_2 = sqrt(max(0.0,s(j))) + T2 = T(j)*T(j) + + num = RN000 + ((T(j)*(RN010 + T(j)*(RN020 + T(j)*RN030)) + & + S(j)*(RN100 + (T(j)*RN110 + S(j)*RN200)) ) + & + pres(j)*(RN001 + ((T2*RN021 + S(j)*RN101) + pres(j)*(RN002 + T2*RN022))) ) + den = 1.0 + ((T(j)*(RD010 + T(j)*(RD020 + T(j)*(RD030 + T(j)* RD040))) + & + S(j)*(RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pres(j)*(RD001 + pres(j)*T(j)*(T2*RD032 + pres(j)*RD013)) ) + + dnum_dT = ((RN010 + T(j)*(2.*RN020 + T(j)*(3.*RN030))) + S(j)*RN110) + & + pres(j)*T(j)*(2.*RN021 + pres(j)*(2.*RN022)) + dnum_dS = (RN100 + (T(j)*RN110 + S(j)*(2.*RN200))) + pres(j)*RN101 + dden_dT = ((RD010 + T(j)*((2.*RD020) + T(j)*((3.*RD030) + T(j)*(4.*RD040)))) + & + S(j)*((RD110 + T2*(3.*RD130)) + S1_2*T(j)*(2.*RD620)) ) + & + pres(j)**2*(T2*3.*RD032 + pres(j)*RD013) + dden_dS = RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_num2 = 1.0 / num**2 + + ! SV(j) = den / num + dSV_dT(j) = (num * dden_dT - dnum_dT * den) * I_num2 + dSV_dS(j) = (num * dden_dS - dnum_dS * den) * I_num2 + enddo + +end subroutine calculate_specvol_derivs_Jackett06 + +!> Computes the compressibility of seawater for 1-d array inputs and outputs +subroutine calculate_compress_Jackett06(T, S, pres, rho, drho_dp, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pres !< Pressure [Pa]. + real, intent(inout), dimension(:) :: rho !< In situ density [kg m-3]. + real, intent(inout), dimension(:) :: 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 !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. + + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expression for density [nondim] + real :: dnum_dp ! The derivative of num with pressure [kg m-3 dbar-1] + real :: dden_dp ! The derivative of den with pressure [dbar-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + integer :: j + + do j=start,start+npts-1 + S1_2 = sqrt(max(0.0,s(j))) + T2 = T(j)*T(j) + + num = RN000 + ((T(j)*(RN010 + T(j)*(RN020 + T(j)*RN030)) + & + S(j)*(RN100 + (T(j)*RN110 + S(j)*RN200)) ) + & + pres(j)*(RN001 + ((T2*RN021 + S(j)*RN101) + pres(j)*(RN002 + T2*RN022))) ) + den = 1.0 + ((T(j)*(RD010 + T(j)*(RD020 + T(j)*(RD030 + T(j)* RD040))) + & + S(j)*(RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pres(j)*(RD001 + pres(j)*T(j)*(T2*RD032 + pres(j)*RD013)) ) + dnum_dp = RN001 + ((T2*RN021 + S(j)*RN101) + pres(j)*(2.*RN002 + T2*(2.*RN022))) + dden_dp = RD001 + pres(j)*T(j)*(T2*(2.*RD032) + pres(j)*(3.*RD013)) + + I_den = 1.0 / den + rho(j) = num * I_den + drho_dp(j) = (dnum_dp * den - num * dden_dp) * I_den**2 + enddo +end subroutine calculate_compress_Jackett06 + +!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. +subroutine calculate_density_second_derivs_array_Jackett(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp, start, npts) + real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] + real, dimension(:), intent(in ) :: S !< Salinity [PSU] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in ) :: start !< Starting index in T,S,P + integer, intent(in ) :: npts !< Number of points to loop over + + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_num2 ! The inverse of the square of the numerator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: dnum_dp ! The derivative of num with pressure [kg m-3 dbar-1] + real :: dden_dp ! The derivative of det with pressure [dbar-1] + real :: d2num_dT2 ! The second derivative of num with potential temperature [kg m-3 degC-2] + real :: d2num_dT_dS ! The second derivative of num with potential temperature and + ! salinity [kg m-3 degC-1 PSU-1] + real :: d2num_dS2 ! The second derivative of num with salinity [kg m-3 PSU-2] + real :: d2num_dT_dp ! The second derivative of num with potential temperature and + ! pressure [kg m-3 degC-1 dbar-1] + real :: d2num_dS_dp ! The second derivative of num with salinity and + ! pressure [kg m-3 PSU-1 dbar-1] + real :: d2den_dT2 ! The second derivative of den with potential temperature [degC-2] + real :: d2den_dT_dS ! The second derivative of den with potential temperature and salinity [degC-1 PSU-1] + real :: d2den_dS2 ! The second derivative of den with salinity [PSU-2] + real :: d2den_dT_dp ! The second derivative of den with potential temperature and pressure [degC-1 dbar-1] + real :: d2den_dS_dp ! The second derivative of den with salinity and pressure [PSU-1 dbar-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + real :: I_s12 ! The inverse of the square root of salinity [PSU-1/2] + real :: I_denom2 ! The inverse of the square of the denominator of the rational expression + ! for density [nondim] + real :: I_denom3 ! The inverse of the cube of the denominator of the rational expression + ! for density [nondim] + integer :: j + + do j = start,start+npts-1 + S1_2 = sqrt(max(0.0,s(j))) + T2 = T(j)*T(j) + + num = RN000 + ((T(j)*(RN010 + T(j)*(RN020 + T(j)*RN030)) + & + S(j)*(RN100 + (T(j)*RN110 + S(j)*RN200)) ) + & + P(j)*(RN001 + ((T2*RN021 + S(j)*RN101) + P(j)*(RN002 + T2*RN022))) ) + den = 1.0 + ((T(j)*(RD010 + T(j)*(RD020 + T(j)*(RD030 + T(j)* RD040))) + & + S(j)*(RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + P(j)*(RD001 + P(j)*T(j)*(T2*RD032 + P(j)*RD013)) ) + ! rho(j) = num*I_den + + dnum_dT = ((RN010 + T(j)*(2.*RN020 + T(j)*(3.*RN030))) + S(j)*RN110) + & + P(j)*T(j)*(2.*RN021 + P(j)*(2.*RN022)) + dnum_dS = (RN100 + (T(j)*RN110 + S(j)*(2.*RN200))) + P(j)*RN101 + dnum_dp = RN001 + ((T2*RN021 + S(j)*RN101) + P(j)*(2.*RN002 + T2*(2.*RN022))) + d2num_dT2 = 2.*RN020 + T(j)*(6.*RN030) + P(j)*(2.*RN021 + P(j)*(2.*RN022)) + d2num_dT_dS = RN110 + d2num_dS2 = 2.*RN200 + d2num_dT_dp = T(j)*(2.*RN021 + P(j)*(4.*RN022)) + d2num_dS_dp = RN101 + + dden_dT = ((RD010 + T(j)*((2.*RD020) + T(j)*((3.*RD030) + T(j)*(4.*RD040)))) + & + S(j)*((RD110 + T2*(3.*RD130)) + S1_2*T(j)*(2.*RD620)) ) + & + P(j)**2*(T2*3.*RD032 + P(j)*RD013) + dden_dS = RD100 + (T(j)*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + dden_dp = RD001 + P(j)*T(j)*(T2*(2.*RD032) + P(j)*(3.*RD013)) + + d2den_dT2 = (((2.*RD020) + T(j)*((6.*RD030) + T(j)*(12.*RD040))) + & + S(j)*(T(j)*(6.*RD130) + S1_2*(2.*RD620)) ) + P(j)**2*(T(j)*(6.*RD032)) + d2den_dT_dS = (RD110 + T2*3.*RD130) + (T(j)*S1_2)*(3.0*RD620) + d2den_dT_dp = P(j)*(T2*(6.*RD032) + P(j)*(3.*RD013)) + d2den_dS_dp = 0.0 + + ! The Jackett et al. 2006 equation of state is a fit to density, but it chooses a form that + ! exhibits a singularity in the second derivatives with salinity for fresh water. To avoid + ! this, the square root of salinity can be treated with a floor such that the contribution from + ! the S**1.5 terms to both the surface density and the secant bulk modulus are lost to roundoff. + ! This salinity is given by (~1e-16/RD600)**(2/3) ~= 7e-8 PSU, or S1_2 ~= 2.6e-4 + I_S12 = 1.0 / (max(S1_2, 1.0e-4)) + d2den_dS2 = (0.75*RD600 + T2*(0.75*RD620)) * I_S12 + + I_denom3 = 1.0 / den**3 + + ! In deriving the following, it is useful to note that: + ! drho_dp(j) = (dnum_dp * den - num * dden_dp) / den**2 + ! drho_dT(j) = (dnum_dT * den - num * dden_dT) / den**2 + ! drho_dS(j) = (dnum_dS * den - num * dden_dS) / den**2 + drho_dS_dS(j) = (den*(den*d2num_dS2 - 2.*dnum_dS*dden_dS) + num*(2.*dden_dS**2 - den*d2den_dS2)) * I_denom3 + drho_dS_dt(j) = (den*(den*d2num_dT_dS - (dnum_dT*dden_dS + dnum_dS*dden_dT)) + & + num*(2.*dden_dT*dden_dS - den*d2den_dT_dS)) * I_denom3 + drho_dT_dT(j) = (den*(den*d2num_dT2 - 2.*dnum_dT*dden_dT) + num*(2.*dden_dT**2 - den*d2den_dT2)) * I_denom3 + + drho_dS_dp(j) = (den*(den*d2num_dS_dp - (dnum_dp*dden_dS + dnum_dS*dden_dp)) + & + num*(2.*dden_dS*dden_dp - den*d2den_dS_dp)) * I_denom3 + drho_dT_dp(j) = (den*(den*d2num_dT_dp - (dnum_dp*dden_dT + dnum_dT*dden_dp)) + & + num*(2.*dden_dT*dden_dp - den*d2den_dT_dp)) * I_denom3 + enddo + +end subroutine calculate_density_second_derivs_array_Jackett + +!> Computes the in situ density of sea water for scalar inputs and outputs. +!! +!! Returns the in situ density of sea water (rho in [kg m-3]) from salinity (S [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. It uses the expression from +!! Jackett et al., 2006, J. Atmos. Ocean. Tech., 32, 1709-1728. +subroutine calculate_density_scalar_Jackett(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: rho0 ! A 1-d array with a copy of the density [kg m-3] + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + call calculate_density_array_Jackett(T0, S0, pressure0, rho0, 1, 1, rho_ref) + rho = rho0(1) + +end subroutine calculate_density_scalar_Jackett + +!> Computes the Jackett et al. 2006 in situ specific volume of sea water for scalar inputs and outputs. +!! +!! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from salinity (S [PSU]), +!! potential temperature (T [degC]) and pressure [Pa]. It uses the expression from +!! Jackett et al., 2006, J. Atmos. Ocean. Tech., 32, 1709-1728. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_Jackett(T, S, pressure, specvol, spv_ref) + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the potential temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: spv0 ! A 1-d array with a copy of the specific volume [m3 kg-1] + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + call calculate_spec_vol_array_Jackett(T0, S0, pressure0, spv0, 1, 1, spv_ref) + specvol = spv0(1) +end subroutine calculate_spec_vol_scalar_Jackett + +!> Return the thermal/haline expansion coefficients for scalar inputs and outputs +!! +!! The scalar version of calculate_density_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar +subroutine calculate_density_derivs_scalar_Jackett(T, S, pressure, drho_dT, drho_dS) + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1]. + + ! Local variables needed to promote the input/output scalars to 1-element arrays + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdt0 ! The derivative of density with temperature [kg m-3 degC-1] + real, dimension(1) :: drds0 ! The derivative of density with salinity [kg m-3 PSU-1] + + T0(1) = T ; S0(1) = S ; P0(1) = pressure + call calculate_density_derivs_array_Jackett(T0, S0, P0, drdt0, drds0, 1, 1) + drho_dT = drdt0(1) ; drho_dS = drds0(1) + +end subroutine calculate_density_derivs_scalar_Jackett + +!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. +!! +!! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array +!! and then demotes the output back to a scalar +subroutine calculate_density_second_derivs_scalar_Jackett(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & + drho_ds_dp, drho_dt_dp) + real, intent(in ) :: T !< Potential temperature referenced to 0 dbar + real, intent(in ) :: S !< Salinity [PSU] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 PSU-2] + real, dimension(1) :: drdsdt ! The second derivative of density with salinity and + ! temperature [kg m-3 PSU-1 degC-1] + real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] + real, dimension(1) :: drdsdp ! The second derivative of density with salinity and + ! pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(1) :: drdtdp ! The second derivative of density with temperature and + ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + T0(1) = T ; S0(1) = S ; P0(1) = P + call calculate_density_second_derivs_array_Jackett(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + drho_ds_ds = drdsds(1) ; drho_ds_dt = drdsdt(1) ; drho_dt_dt = drdtdt(1) + drho_ds_dp = drdsdp(1) ; drho_dt_dp = drdtdp(1) + +end subroutine calculate_density_second_derivs_scalar_Jackett + +!> \namespace mom_eos_Jackett06 +!! +!! \section section_EOS_Jackett06 Jackett et al. 2006 (Hycom-25-term) equation of state +!! +!! Jackett et al. (2006) provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. This 25 term equation of state is +!! frequently used in Hycom for a potential density, at which point it only has 17 terms +!! and so is commonly called the "17-term equation of state" there. Here the full expressions +!! for the in situ densities are used. +!! +!! \subsection section_EOS_Jackett06_references References +!! +!! Jackett, D., T. McDougall, R. Feistel, D. Wright and S. Griffies (2006), +!! Algorithms for density, potential temperature, conservative +!! temperature, and the freezing temperature of seawater, JAOT +!! doi.org/10.1175/JTECH1946.1 + +end module MOM_EOS_Jackett06 From b8a74cceb70e7369fb4a4b575808322de1ba0a75 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Mar 2023 17:39:36 -0500 Subject: [PATCH 57/91] *+Add calculate_specvol_derivs_UNESCO Added the routine calculate_specvol_derivs_UNESCO to calculate the derivatives of specific volume with temperature and salinity to the MOM_EOS_UNESCO module. Also added some missing parentheses elsewhere in this module so that the answers will be invariant to complier version and optimization levels. Also revised the internal nomenclature of the parameters in this module to follow the conventions of the other EOS modules. Although the revised expressions are mathematically equivalent, this commit will change answers for any cases that use EQN_OF_STATE = "UNESCO". However, it is believed based on a survey of the MOM6 community that there are no active configurations that use this equation of state. There is a new publicly visible routine. --- src/equation_of_state/MOM_EOS.F90 | 17 +- src/equation_of_state/MOM_EOS_UNESCO.F90 | 335 ++++++++++++++--------- 2 files changed, 204 insertions(+), 148 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 1640fb6e0e..f79d304dfc 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -27,7 +27,7 @@ module MOM_EOS use MOM_EOS_Jackett06, only : calculate_density_derivs_Jackett06, calculate_specvol_derivs_Jackett06 use MOM_EOS_Jackett06, only : calculate_compress_Jackett06, calculate_density_second_derivs_Jackett06 use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco -use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco +use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_specvol_derivs_UNESCO use MOM_EOS_UNESCO, only : calculate_density_second_derivs_UNESCO, calculate_compress_unesco use MOM_EOS_NEMO, only : calculate_density_nemo use MOM_EOS_NEMO, only : calculate_density_derivs_nemo @@ -331,7 +331,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re call calculate_density_linear(T, S, pressure, rho, start, npts, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_UNESCO(T, S, pressure, rho, start, npts, rho_ref) case (EOS_WRIGHT) call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) case (EOS_WRIGHT_FULL) @@ -636,7 +636,7 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s call calculate_spec_vol_linear(T, S, pressure, specvol, start, npts, & EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_ref) case (EOS_UNESCO) - call calculate_spec_vol_unesco(T, S, pressure, specvol, start, npts, spv_ref) + call calculate_spec_vol_UNESCO(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_WRIGHT) call calculate_spec_vol_wright(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_WRIGHT_FULL) @@ -931,7 +931,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, EOS%Rho_T0_S0, & EOS%dRho_dT, EOS%dRho_dS, start, npts) case (EOS_UNESCO) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) + call calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_WRIGHT) call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_WRIGHT_FULL) @@ -1333,12 +1333,7 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo + call calculate_specvol_derivs_UNESCO(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_WRIGHT) call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_WRIGHT_FULL) @@ -1455,7 +1450,7 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) call calculate_compress_linear(Ta, Sa, pres, rho, drho_dp, is, npts, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_UNESCO) - call calculate_compress_unesco(Ta, Sa, pres, rho, drho_dp, is, npts) + call calculate_compress_UNESCO(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_WRIGHT) call calculate_compress_wright(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_WRIGHT_FULL) diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index b6398e07e2..ae9cf72aaa 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -6,7 +6,7 @@ module MOM_EOS_UNESCO implicit none ; private public calculate_compress_UNESCO, calculate_density_UNESCO, calculate_spec_vol_UNESCO -public calculate_density_derivs_UNESCO +public calculate_density_derivs_UNESCO, calculate_specvol_derivs_UNESCO public calculate_density_scalar_UNESCO, calculate_density_array_UNESCO public calculate_density_second_derivs_UNESCO @@ -32,57 +32,56 @@ module MOM_EOS_UNESCO !>@{ Parameters in the UNESCO equation of state, as published in appendix A3 of Gill, 1982. -! The following constants are used to calculate rho0, the density of seawater at 1 -! atmosphere pressure. The notation is Rab for the contribution to rho0 from T^a*S^b. +! The following constants are used to calculate rho0, the density of seawater at 1 atmosphere pressure. +! The notation is Rab for the contribution to rho0 from S^a*T^b, with 6 used for the 1.5 power. real, parameter :: R00 = 999.842594 ! A coefficient in the fit for rho0 [kg m-3] -real, parameter :: R10 = 6.793952e-2 ! A coefficient in the fit for rho0 [kg m-3 degC-1] -real, parameter :: R20 = -9.095290e-3 ! A coefficient in the fit for rho0 [kg m-3 degC-2] -real, parameter :: R30 = 1.001685e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-3] -real, parameter :: R40 = -1.120083e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-4] -real, parameter :: R50 = 6.536332e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-5] -real, parameter :: R01 = 0.824493 ! A coefficient in the fit for rho0 [kg m-3 PSU-1] +real, parameter :: R01 = 6.793952e-2 ! A coefficient in the fit for rho0 [kg m-3 degC-1] +real, parameter :: R02 = -9.095290e-3 ! A coefficient in the fit for rho0 [kg m-3 degC-2] +real, parameter :: R03 = 1.001685e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-3] +real, parameter :: R04 = -1.120083e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-4] +real, parameter :: R05 = 6.536332e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-5] +real, parameter :: R10 = 0.824493 ! A coefficient in the fit for rho0 [kg m-3 PSU-1] real, parameter :: R11 = -4.0899e-3 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-1] -real, parameter :: R21 = 7.6438e-5 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-1] -real, parameter :: R31 = -8.2467e-7 ! A coefficient in the fit for rho0 [kg m-3 degC-3 PSU-1] -real, parameter :: R41 = 5.3875e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-4 PSU-1] -real, parameter :: R032 = -5.72466e-3 ! A coefficient in the fit for rho0 [kg m-3 PSU-3/2] -real, parameter :: R132 = 1.0227e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-3/2] -real, parameter :: R232 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-3/2] -real, parameter :: R02 = 4.8314e-4 ! A coefficient in the fit for rho0 [kg m-3 PSU-2] +real, parameter :: R12 = 7.6438e-5 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-1] +real, parameter :: R13 = -8.2467e-7 ! A coefficient in the fit for rho0 [kg m-3 degC-3 PSU-1] +real, parameter :: R14 = 5.3875e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-4 PSU-1] +real, parameter :: R60 = -5.72466e-3 ! A coefficient in the fit for rho0 [kg m-3 PSU-1.5] +real, parameter :: R61 = 1.0227e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-1.5] +real, parameter :: R62 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-1.5] +real, parameter :: R20 = 4.8314e-4 ! A coefficient in the fit for rho0 [kg m-3 PSU-2] ! The following constants are used to calculate the secant bulk modulus. -! The notation here is Sab for terms proportional to T^a*S^b, -! SpABC for terms proportional to p^A*T^B*S^C. +! The notation here is Sabc for terms proportional to S^a*T^b*P^c, with 6 used for the 1.5 power. ! Note that these values differ from those in Appendix 3 of Gill (1982) because the expressions ! from Jackett and MacDougall (1995) use potential temperature, rather than in situ temperature. -real, parameter :: S00 = 1.965933e4 ! A coefficient in the secant bulk modulus fit [bar] -real, parameter :: S10 = 1.444304e2 ! A coefficient in the secant bulk modulus fit [bar degC-1] -real, parameter :: S20 = -1.706103 ! A coefficient in the secant bulk modulus fit [bar degC-2] -real, parameter :: S30 = 9.648704e-3 ! A coefficient in the secant bulk modulus fit [bar degC-3] -real, parameter :: S40 = -4.190253e-5 ! A coefficient in the secant bulk modulus fit [bar degC-4] -real, parameter :: S01 = 52.84855 ! A coefficient in the secant bulk modulus fit [bar PSU-1] -real, parameter :: S11 = -3.101089e-1 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-1] -real, parameter :: S21 = 6.283263e-3 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-1] -real, parameter :: S31 = -5.084188e-5 ! A coefficient in the secant bulk modulus fit [bar degC-3 PSU-1] -real, parameter :: S032 = 3.886640e-1 ! A coefficient in the secant bulk modulus fit [bar PSU-3/2] -real, parameter :: S132 = 9.085835e-3 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-3/2] -real, parameter :: S232 = -4.619924e-4 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-3/2] - -real, parameter :: Sp100 = 3.186519 ! A coefficient in the secant bulk modulus fit [nondim] -real, parameter :: Sp110 = 2.212276e-2 ! A coefficient in the secant bulk modulus fit [degC-1] -real, parameter :: Sp120 = -2.984642e-4 ! A coefficient in the secant bulk modulus fit [degC-2] -real, parameter :: Sp130 = 1.956415e-6 ! A coefficient in the secant bulk modulus fit [degC-3] -real, parameter :: Sp101 = 6.704388e-3 ! A coefficient in the secant bulk modulus fit [PSU-1] -real, parameter :: Sp111 = -1.847318e-4 ! A coefficient in the secant bulk modulus fit [degC-1 PSU-1] -real, parameter :: Sp121 = 2.059331e-7 ! A coefficient in the secant bulk modulus fit [degC-2 PSU-1] -real, parameter :: Sp1032 = 1.480266e-4 ! A coefficient in the secant bulk modulus fit [PSU-3/2] - -real, parameter :: Sp200 = 2.102898e-4 ! A coefficient in the secant bulk modulus fit [bar-1] -real, parameter :: Sp210 = -1.202016e-5 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1] -real, parameter :: Sp220 = 1.394680e-7 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2] -real, parameter :: Sp201 = -2.040237e-6 ! A coefficient in the secant bulk modulus fit [bar-1 PSU-1] -real, parameter :: Sp211 = 6.128773e-8 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-1] -real, parameter :: Sp221 = 6.207323e-10 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-2] +real, parameter :: S000 = 1.965933e4 ! A coefficient in the secant bulk modulus fit [bar] +real, parameter :: S010 = 1.444304e2 ! A coefficient in the secant bulk modulus fit [bar degC-1] +real, parameter :: S020 = -1.706103 ! A coefficient in the secant bulk modulus fit [bar degC-2] +real, parameter :: S030 = 9.648704e-3 ! A coefficient in the secant bulk modulus fit [bar degC-3] +real, parameter :: S040 = -4.190253e-5 ! A coefficient in the secant bulk modulus fit [bar degC-4] +real, parameter :: S100 = 52.84855 ! A coefficient in the secant bulk modulus fit [bar PSU-1] +real, parameter :: S110 = -3.101089e-1 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-1] +real, parameter :: S120 = 6.283263e-3 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-1] +real, parameter :: S130 = -5.084188e-5 ! A coefficient in the secant bulk modulus fit [bar degC-3 PSU-1] +real, parameter :: S600 = 3.886640e-1 ! A coefficient in the secant bulk modulus fit [bar PSU-1.5] +real, parameter :: S610 = 9.085835e-3 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-1.5] +real, parameter :: S620 = -4.619924e-4 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-1.5] + +real, parameter :: S001 = 3.186519 ! A coefficient in the secant bulk modulus fit [nondim] +real, parameter :: S011 = 2.212276e-2 ! A coefficient in the secant bulk modulus fit [degC-1] +real, parameter :: S021 = -2.984642e-4 ! A coefficient in the secant bulk modulus fit [degC-2] +real, parameter :: S031 = 1.956415e-6 ! A coefficient in the secant bulk modulus fit [degC-3] +real, parameter :: S101 = 6.704388e-3 ! A coefficient in the secant bulk modulus fit [PSU-1] +real, parameter :: S111 = -1.847318e-4 ! A coefficient in the secant bulk modulus fit [degC-1 PSU-1] +real, parameter :: S121 = 2.059331e-7 ! A coefficient in the secant bulk modulus fit [degC-2 PSU-1] +real, parameter :: S601 = 1.480266e-4 ! A coefficient in the secant bulk modulus fit [PSU-1.5] + +real, parameter :: S002 = 2.102898e-4 ! A coefficient in the secant bulk modulus fit [bar-1] +real, parameter :: S012 = -1.202016e-5 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1] +real, parameter :: S022 = 1.394680e-7 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2] +real, parameter :: S102 = -2.040237e-6 ! A coefficient in the secant bulk modulus fit [bar-1 PSU-1] +real, parameter :: S112 = 6.128773e-8 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-1] +real, parameter :: S122 = 6.207323e-10 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2 PSU-1] !>@} contains @@ -142,18 +141,18 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). - sig0 = ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & - s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & - (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) + sig0 = ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) rho0 = R00 + sig0 ! Compute rho(s,theta,p), first calculating the secant bulk modulus. - ks = (S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & - s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) )) + & - p1*( (Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & - s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) )) + & - p1*(Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) )) ) + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) if (present(rho_ref)) then rho(j) = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) @@ -215,17 +214,17 @@ subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). - rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & - s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & - (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) ! Compute rho(s,theta,p), first calculating the secant bulk modulus. - ks = (S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & - s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) )) + & - p1*( (Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & - s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) )) + & - p1*(Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) )) ) + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) if (present(spv_ref)) then specvol(j) = (ks*(1.0 - (rho0*spv_ref)) - p1) / (rho0*ks) @@ -260,46 +259,106 @@ subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, sta real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] real :: dks_dT ! Derivative of ks with T [bar degC-1] real :: dks_dS ! Derivative of ks with S [bar psu-1] - real :: denom ! 1.0 / (ks - p1) [bar-1] + real :: I_denom ! 1.0 / (ks - p1) [bar-1] integer :: j do j=start,start+npts-1 - p1 = pressure(j)*1.0e-5 ; t1 = T(j) s1 = max(S(j), 0.0) ; s12 = sqrt(s1) - ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + ! Compute rho(s,theta,p=0) and its derivatives with temperature and salinity + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + (t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) )) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + + ! Compute the secant bulk modulus and its derivatives with temperature and salinity + ks = ( S000 + (t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + dks_dT = ( S010 + (t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620)))) ) + & + p1*(((S011 + t1*(2.0*S021 + t1*(3.0*S031))) + s1*(S111 + t1*(2.0*S121)) ) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) ) + dks_dS = ( S100 + (t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122)) ) - rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & - s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & - (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) - drho0_dT = R10 + ( t1*(2.0*R20 + t1*(3.0*R30 + t1*(4.0*R40 + 5.0*R50*t1))) + & - s1*(R11 + (t1*(2.0*R21 + t1*(3.0*R31 + 4.0*R41*t1)) + & - s12*(R132 + 2.0*R232*t1))) ) - drho0_dS = R01 + ( t1*(R11 + t1*(R21 + t1*(R31 + R41*t1))) + & - (1.5*s12*(R032 + t1*(R132 + R232*t1)) + 2.0*R02*s1) ) + I_denom = 1.0 / (ks - p1) + drho_dT(j) = (ks*drho0_dT - dks_dT*((rho0*p1)*I_denom)) * I_denom + drho_dS(j) = (ks*drho0_dS - dks_dS*((rho0*p1)*I_denom)) * I_denom + enddo - ! Compute rho(s,theta,p), first calculating the secant bulk modulus. +end subroutine calculate_density_derivs_UNESCO + +!> Return the partial derivatives of specific volume with temperature and salinity +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +subroutine calculate_specvol_derivs_UNESCO(T, S, pressure, dSV_dT, dSV_dS, start, npts) + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. + real, intent(inout), dimension(:) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1]. + real, intent(inout), dimension(:) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. - ks = ( S00 + (t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & - s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1)))) ) + & - p1*( (Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & - s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) )) + & - p1*(Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) )) ) - dks_dT = ( S10 + (t1*(2.0*S20 + t1*(3.0*S30 + t1*4.0*S40)) + & - s1*((S11 + t1*(2.0*S21 + 3.0*S31*t1)) + s12*(S132 + 2.0*S232*t1))) ) + & - p1*((Sp110 + t1*(2.0*Sp120 + 3.0*Sp130*t1) + s1*(Sp111 + 2.0*Sp121*t1)) + & - p1*(Sp210 + 2.0*Sp220*t1 + s1*(Sp211 + 2.0*Sp221*t1))) - dks_dS = ( S01 + (t1*(S11 + t1*(S21 + S31*t1)) + 1.5*s12*(S032 + t1*(S132 + S232*t1))) ) + & - p1*((Sp101 + t1*(Sp111 + Sp121*t1) + 1.5*Sp1032*s12) + & - p1*(Sp201 + t1*(Sp211 + Sp221*t1))) - - denom = 1.0 / (ks - p1) - drho_dT(j) = denom*(ks*drho0_dT - rho0*p1*denom*dks_dT) - drho_dS(j) = denom*(ks*drho0_dS - rho0*p1*denom*dks_dS) + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: dks_dT ! Derivative of ks with T [bar degC-1] + real :: dks_dS ! Derivative of ks with S [bar psu-1] + real :: I_denom2 ! 1.0 / (rho0*ks)**2 [m6 kg-2 bar-2] + integer :: j + + do j=start,start+npts-1 + p1 = pressure(j)*1.0e-5 ; t1 = T(j) + s1 = max(S(j), 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) and its derivatives with temperature and salinity + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + (t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) )) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + + ! Compute the secant bulk modulus and its derivatives with temperature and salinity + ks = ( S000 + (t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + dks_dT = ( S010 + (t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620)))) ) + & + p1*(((S011 + t1*(2.0*S021 + t1*(3.0*S031))) + s1*(S111 + t1*(2.0*S121)) ) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) ) + dks_dS = ( S100 + (t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122)) ) + + ! specvol(j) = (ks - p1) / (rho0*ks) = 1/rho0 - p1/(rho0*ks) + I_denom2 = 1.0 / (rho0*ks)**2 + dSV_dT(j) = ((p1*rho0)*dks_dT + ((p1 - ks)*ks)*drho0_dT) * I_denom2 + dSV_dS(j) = ((p1*rho0)*dks_dS + ((p1 - ks)*ks)*drho0_dS) * I_denom2 enddo -end subroutine calculate_density_derivs_UNESCO +end subroutine calculate_specvol_derivs_UNESCO !> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) !! at the given salinity, potential temperature and pressure using the UNESCO (1981) @@ -327,6 +386,7 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] + real :: I_denom ! 1.0 / (ks - p1) [bar-1] integer :: j do j=start,start+npts-1 @@ -335,24 +395,25 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). - rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & - s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & - (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) ! Calculate the secant bulk modulus and its derivative with pressure. - ks_0 = S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & - s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) ) - ks_1 = Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & - s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) ) - ks_2 = Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) ) + ks_0 = S000 + ( t1*( S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) ) + ks_1 = S001 + ( t1*( S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) ) + ks_2 = S002 + ( t1*( S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) ) ks = ks_0 + p1*(ks_1 + p1*ks_2) dks_dp = ks_1 + 2.0*p1*ks_2 + I_denom = 1.0 / (ks - p1) ! Compute the in situ density, rho(s,theta,p), and its derivative with pressure. - rho(j) = rho0*ks / (ks - p1) + rho(j) = rho0*ks * I_denom ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. - drho_dp(j) = 1.0e-5 * (rho(j) / (ks - p1)) * (1.0 - dks_dp*p1/ks) + drho_dp(j) = 1.0e-5 * ((rho0 * (ks - p1*dks_dp)) * I_denom**2) enddo end subroutine calculate_compress_UNESCO @@ -411,49 +472,49 @@ subroutine calculate_density_second_derivs_array_UNESCO(T, S, P, drho_ds_ds, drh ! singularity in the second derivatives with salinity for fresh water. To avoid this, the ! square root of salinity can be treated with a floor such that the contribution from the ! S**1.5 terms to both the surface density and the secant bulk modulus are lost to roundoff. - ! This salinity is given by (~1e-16*S00/S032)**(2/3) ~= 3e-8 PSU, or S12 ~= 1.7e-4 + ! This salinity is given by (~1e-16*S000/S600)**(2/3) ~= 3e-8 PSU, or S12 ~= 1.7e-4 I_s12 = 1.0 / (max(s12, 1.0e-4)) ! Calculate the density at sea level pressure and its derivatives - rho0 = R00 + ( t1*(R10 + t1*(R20 + t1*(R30 + t1*(R40 + R50*t1)))) + & - s1*((R01 + t1*(R11 + t1*(R21 + t1*(R31 + R41*t1)))) + & - (s12*(R032 + t1*(R132 + R232*t1)) + R02*s1)) ) - drho0_dT = R10 + ( t1*(2.0*R20 + t1*(3.0*R30 + t1*(4.0*R40 + 5.0*R50*t1))) + & - s1*(R11 + ( t1*(2.0*R21 + t1*(3.0*R31 + 4.0*R41*t1)) + & - s12*(R132 + 2.0*R232*t1) ) ) ) - drho0_dS = R01 + ( t1*(R11 + t1*(R21 + t1*(R31 + R41*t1))) + & - (1.5*s12*(R032 + t1*(R132 + R232*t1)) + 2.0*R02*s1) ) - d2rho0_dS2 = 0.75*(R032 + t1*(R132 + R232*t1))*I_s12 + 2.0*R02 - d2rho0_dSdT = R11 + ( t1*(2.0*R21 + t1*(3.0*R31 + 4.0*R41*t1)) + 1.5*s12*(R132 + 2.0*R232*t1) ) - d2rho0_dT2 = 2.0*R20 + ( t1*(6.0*R30 + t1*(12.0*R40 + 20.0*R50*t1)) + & - s1*((2.0*R21 + t1*(6.0*R31 + 12.0*R41*t1)) + 2.0*R232*s12) ) + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + ( t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) ) ) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + d2rho0_dS2 = 0.75*(R60 + t1*(R61 + t1*R62))*I_s12 + 2.0*R20 + d2rho0_dSdT = R11 + ( t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + s12*(1.5*R61 + t1*(3.0*R62)) ) + d2rho0_dT2 = 2.0*R02 + ( t1*(6.0*R03 + t1*(12.0*R04 + t1*(20.0*R05))) + & + s1*((2.0*R12 + t1*(6.0*R13 + t1*(12.0*R14))) + s12*(2.0*R62)) ) ! Calculate the secant bulk modulus and its derivatives - ks_0 = S00 + ( t1*(S10 + t1*(S20 + t1*(S30 + S40*t1))) + & - s1*((S01 + t1*(S11 + t1*(S21 + S31*t1))) + s12*(S032 + t1*(S132 + S232*t1))) ) - ks_1 = Sp100 + ( t1*(Sp110 + t1*(Sp120 + Sp130*t1)) + & - s1*((Sp101 + t1*(Sp111 + Sp121*t1)) + Sp1032*s12) ) - ks_2 = Sp200 + ( t1*(Sp210 + Sp220*t1) + s1*(Sp201 + t1*(Sp211 + Sp221*t1)) ) + ks_0 = S000 + ( t1*( S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) ) + ks_1 = S001 + ( t1*( S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) ) + ks_2 = S002 + ( t1*( S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) ) ks = ks_0 + p1*(ks_1 + p1*ks_2) dks_dp = ks_1 + 2.0*p1*ks_2 - dks_dT = (S10 + ( t1*(2.0*S20 + t1*(3.0*S30 + t1*4.0*S40)) + & - s1*((S11 + t1*(2.0*S21 + 3.0*S31*t1)) + s12*(S132 + 2.0*S232*t1)) )) + & - p1*((Sp110 + t1*(2.0*Sp120 + 3.0*Sp130*t1) + s1*(Sp111 + 2.0*Sp121*t1)) + & - p1*(Sp210 + 2.0*Sp220*t1 + s1*(Sp211 + 2.0*Sp221*t1))) - dks_dS = (S01 + ( t1*(S11 + t1*(S21 + S31*t1)) + 1.5*s12*(S032 + t1*(S132 + S232*t1)) )) + & - p1*((Sp101 + t1*(Sp111 + Sp121*t1) + 1.5*Sp1032*s12) + & - p1*(Sp201 + t1*(Sp211 + Sp221*t1))) - d2ks_dS2 = 0.75*((S032 + t1*(S132 + S232*t1)) + p1*Sp1032)*I_s12 - d2ks_dSdT = (S11 + ( t1*(2.0*S21 + 3.0*S31*t1) + 1.5*s12*(S132 + 2.0*S232*t1) )) + & - p1*((Sp111 + 2.0*Sp121*t1) + p1*(Sp211 + 2.0*Sp221*t1)) - d2ks_dT2 = 2.0*(S20 + ( t1*(3.0*S30 + 6.0*S40*t1) + s1*((S21 + 3.0*S31*t1) + S232*s12) )) + & - 2.0*p1*((Sp120 + (3.0*Sp130*t1 + Sp121*s1)) + p1*(Sp220 + Sp221*s1)) - - d2ks_dSdp = (Sp101 + (t1*(Sp111 + Sp121*t1) + 1.5*Sp1032*s12)) + & - 2.0*p1*(Sp201 + t1*(Sp211 + Sp221*t1)) - d2ks_dTdp = (Sp110 + (t1*(2.0*Sp120 + 3.0*Sp130*t1) + s1*(Sp111 + 2.0*Sp121*t1))) + & - 2.0*p1*(Sp210 + 2.0*Sp220*t1 + s1*(Sp211 + 2.0*Sp221*t1)) + dks_dT = (S010 + ( t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620))) )) + & + p1*((S011 + t1*(2.0*S021 + t1*(3.0*S031)) + s1*(S111 + t1*(2.0*S121))) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122)))) + dks_dS = (S100 + ( t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122))) + d2ks_dS2 = 0.75*((S600 + t1*(S610 + t1*S620)) + p1*S601)*I_s12 + d2ks_dSdT = (S110 + ( t1*(2.0*S120 + t1*(3.0*S130)) + s12*(1.5*S610 + t1*(3.0*S620)) )) + & + p1*((S111 + t1*(2.0*S121)) + p1*(S112 + t1*(2.0*S122))) + d2ks_dT2 = 2.0*(S020 + ( t1*(3.0*S030 + t1*(6.0*S040)) + s1*((S120 + t1*(3.0*S130)) + s12*S620) )) + & + 2.0*p1*((S021 + (t1*(3.0*S031) + s1*S121)) + p1*(S022 + s1*S122)) + + d2ks_dSdp = (S101 + (t1*(S111 + t1*S121) + s12*(1.5*S601))) + & + 2.0*p1*(S102 + t1*(S112 + t1*S122)) + d2ks_dTdp = (S011 + (t1*(2.0*S021 + t1*(3.0*S031)) + s1*(S111 + t1*(2.0*S121)))) + & + 2.0*p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) I_denom = 1.0 / (ks - p1) ! Expressions for density and its first derivatives are copied here for reference: @@ -467,7 +528,7 @@ subroutine calculate_density_second_derivs_array_UNESCO(T, S, P, drho_ds_ds, drh (2.0*drho0_dS*dks_dS + rho0*(d2ks_dS2 - 2.0*dks_dS**2*I_denom)) ) drho_dS_dT(j) = I_denom * (ks * d2rho0_dSdT - (p1*I_denom) * & ((drho0_dT*dks_dS + drho0_dS*dks_dT) + & - rho0*(d2ks_dSdT - 2.0*(dks_dS*dks_dT)*I_denom)) ) + rho0*(d2ks_dSdT - 2.0*(dks_dS*dks_dT)*I_denom)) ) drho_dT_dT(j) = I_denom * ( ks*d2rho0_dT2 - (p1*I_denom) * & (2.0*drho0_dT*dks_dT + rho0*(d2ks_dT2 - 2.0*dks_dT**2*I_denom)) ) From 7f164daeca259d8dd2f9c0fbf722d62f1b561225 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 10 Mar 2023 07:39:00 -0500 Subject: [PATCH 58/91] +Add EOS_fit_range and analogs for each EoS Added the new publicly visible subroutine EOS_fit_range and equivalent routines for each of the specific equation of state modules to return the range of temperatures, salinities, and pressures over which the observed data have been fitted. This is also tested for in test_EOS_consistency to indicate whether a test value is outside of the fit range, but the real purpose will be to flag and then figure out how to deal with the case when the ocean model is called with properties for which the equation of state is not valid. Note that as with all polynomial or other functional fits, extrapolating far outside of the fit range is likely to lead to bad values, but things may not be so bad for values that are only slightly outside of this range. However the question of how far out of the fit range these EoS expressions become inappropriate for each of temperature, salinity and pressure is as yet unresolved. All answers and output are bitwise identical, but there are 10 new public interfaces. --- src/equation_of_state/MOM_EOS.F90 | 78 ++++++++++++++++++- src/equation_of_state/MOM_EOS_Jackett06.F90 | 31 +++++++- src/equation_of_state/MOM_EOS_NEMO.F90 | 22 +++++- src/equation_of_state/MOM_EOS_Roquet_SpV.F90 | 22 +++++- src/equation_of_state/MOM_EOS_TEOS10.F90 | 26 ++++++- src/equation_of_state/MOM_EOS_UNESCO.F90 | 22 +++++- src/equation_of_state/MOM_EOS_Wright.F90 | 21 +++++ src/equation_of_state/MOM_EOS_Wright_full.F90 | 22 +++++- src/equation_of_state/MOM_EOS_Wright_red.F90 | 22 +++++- src/equation_of_state/MOM_EOS_linear.F90 | 22 +++++- 10 files changed, 275 insertions(+), 13 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index f79d304dfc..1628ceb594 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -6,38 +6,46 @@ module MOM_EOS use MOM_EOS_linear, only : calculate_density_linear, calculate_spec_vol_linear use MOM_EOS_linear, only : calculate_density_derivs_linear use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear -use MOM_EOS_linear, only : calculate_density_second_derivs_linear +use MOM_EOS_linear, only : calculate_density_second_derivs_linear, EoS_fit_range_linear use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright use MOM_EOS_Wright, only : calculate_density_derivs_wright use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright use MOM_EOS_Wright, only : calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy +use MOM_EOS_Wright, only : EoS_fit_range_Wright use MOM_EOS_Wright_full, only : calculate_density_wright_full, calculate_spec_vol_wright_full use MOM_EOS_Wright_full, only : calculate_density_derivs_wright_full use MOM_EOS_Wright_full, only : calculate_specvol_derivs_wright_full, int_density_dz_wright_full use MOM_EOS_Wright_full, only : calculate_compress_wright_full, int_spec_vol_dp_wright_full use MOM_EOS_Wright_full, only : calculate_density_second_derivs_wright_full +use MOM_EOS_Wright_full, only : EoS_fit_range_Wright_full use MOM_EOS_Wright_red, only : calculate_density_wright_red, calculate_spec_vol_wright_red use MOM_EOS_Wright_red, only : calculate_density_derivs_wright_red use MOM_EOS_Wright_red, only : calculate_specvol_derivs_wright_red, int_density_dz_wright_red use MOM_EOS_Wright_red, only : calculate_compress_wright_red, int_spec_vol_dp_wright_red use MOM_EOS_Wright_red, only : calculate_density_second_derivs_wright_red +use MOM_EOS_Wright_red, only : EoS_fit_range_Wright_red use MOM_EOS_Jackett06, only : calculate_density_Jackett06, calculate_spec_vol_Jackett06 use MOM_EOS_Jackett06, only : calculate_density_derivs_Jackett06, calculate_specvol_derivs_Jackett06 use MOM_EOS_Jackett06, only : calculate_compress_Jackett06, calculate_density_second_derivs_Jackett06 +use MOM_EOS_Jackett06, only : EoS_fit_range_Jackett06 use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_specvol_derivs_UNESCO use MOM_EOS_UNESCO, only : calculate_density_second_derivs_UNESCO, calculate_compress_unesco +use MOM_EOS_UNESCO, only : EoS_fit_range_UNESCO use MOM_EOS_NEMO, only : calculate_density_nemo use MOM_EOS_NEMO, only : calculate_density_derivs_nemo use MOM_EOS_NEMO, only : calculate_density_second_derivs_NEMO, calculate_compress_nemo +use MOM_EOS_NEMO, only : EoS_fit_range_NEMO use MOM_EOS_Roquet_SpV, only : calculate_density_Roquet_SpV, calculate_spec_vol_Roquet_SpV use MOM_EOS_Roquet_SpV, only : calculate_density_derivs_Roquet_SpV, calculate_specvol_derivs_Roquet_SpV use MOM_EOS_Roquet_SpV, only : calculate_compress_Roquet_SpV, calculate_density_second_derivs_Roquet_SpV +use MOM_EOS_Roquet_SpV, only : EoS_fit_range_Roquet_SpV use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10, calculate_specvol_derivs_teos10 use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10, calculate_compress_teos10 +use MOM_EOS_TEOS10, only : EoS_fit_range_TEOS10 use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero use MOM_TFreeze, only : calculate_TFreeze_teos10 @@ -57,6 +65,7 @@ module MOM_EOS public EOS_manual_init public EOS_quadrature public EOS_use_linear +public EOS_fit_range public EOS_unit_tests public analytic_int_density_dz public analytic_int_specific_vol_dp @@ -1506,6 +1515,43 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) end subroutine calculate_compress_scalar +!> Return the range of temperatures, salinities and pressures for which the equation of state that +!! is being used has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(out) :: T_min !< The minimum temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: S_max !< The maximum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call EoS_fit_range_linear(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_UNESCO) + call EoS_fit_range_UNESCO(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_WRIGHT) + call EoS_fit_range_Wright(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_WRIGHT_FULL) + call EoS_fit_range_Wright_full(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_WRIGHT_RED) + call EoS_fit_range_Wright_red(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_TEOS10) + call EoS_fit_range_TEOS10(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_NEMO) + call EoS_fit_range_NEMO(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_ROQUET_SpV) + call EoS_fit_range_Roquet_SpV(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_JACKETT06) + call EoS_fit_range_Jackett06(T_min, T_max, S_min, S_max, p_min, p_max) + case default + call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") + end select + +end subroutine EoS_fit_range + !> This subroutine returns a two point integer array indicating the domain of i-indices !! to work on in EOS calls based on information from a hor_index type @@ -2119,6 +2165,13 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_RED EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail + ! This test is deliberately outside of the fit range for WRIGHT_RED, and it results in the expected warnings. + ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_RED) + ! fail = test_EOS_consistency(25.0, 15.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_RED", & + ! rho_check=1012.625699301455*EOS_tmp%kg_m3_to_R) + ! if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_RED EOS has failed some self-consistency tests.") + ! EOS_unit_tests = EOS_unit_tests .or. fail + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R) @@ -2144,9 +2197,10 @@ logical function EOS_unit_tests(verbose) EOS_unit_tests = EOS_unit_tests .or. fail ! The TEOS10 equation of state is not passing the self consistency tests for dho_dS_dp due - ! to a bug (a missing division by the square root of salinity) on line 109 of + ! to a bug (a missing division by the square root of offset-salinity) on line 111 of ! pkg/GSW-Fortan/toolbox/gsw_specvol_second_derivatives.f90. This bug has been highlighted in an - ! issue posted to the TEOS-10/GSW-Fortran page at github.com/TEOS-10/GSW-Fortran/issues/26. + ! issue posted to the TEOS-10/GSW-Fortran page at github.com/TEOS-10/GSW-Fortran/issues/26, and + ! it will be corrected by github.com/mom-ocean/GSW-Fortran/pull/1 . call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", skip_2nd=.true., & rho_check=1027.42355961492*EOS_tmp%kg_m3_to_R) @@ -2251,6 +2305,9 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & real :: r_tol ! Roundoff error on a typical value of density anomaly [R ~> kg m-3] real :: sv_tol ! Roundoff error on a typical value of specific volume anomaly [R-1 ~> m3 kg-1] real :: tol_here ! The tolerance for each check, in various units [various] + real :: T_min, T_max ! The minimum and maximum temperature over which this EoS is fitted [degC] + real :: S_min, S_max ! The minimum and maximum temperature over which this EoS is fitted [ppt] + real :: p_min, p_max ! The minimum and maximum temperature over which this EoS is fitted [Pa] real :: count_fac ! A factor in the roundoff estimates based on the factors in the numerator and ! denominator in the finite difference derivative expression [nondim] real :: count_fac2 ! A factor in the roundoff estimates based on the factors in the numerator and @@ -2275,6 +2332,21 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & order = 4 ! This should be 2, 4 or 6. + ! Check whether the consistency test is being applied outside of the value range of this EoS. + call EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) + if ((T_test < T_min) .or. (T_test > T_max)) then + write(mesg, '(ES12.4," [degC] which is outside of the fit range of ",ES12.4," to ",ES12.4)') T_test, T_min, T_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a temperature of "//trim(mesg)) + endif + if ((S_test < S_min) .or. (S_test > S_max)) then + write(mesg, '(ES12.4," [ppt] which is outside of the fit range of ",ES12.4," to ",ES12.4)') S_test, S_min, S_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a salinity of "//trim(mesg)) + endif + if ((p_test < p_min) .or. (p_test > p_max)) then + write(mesg, '(ES12.4," [Pa] which is outside of the fit range of ",ES12.4," to ",ES12.4)') p_test, p_min, p_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a pressure of "//trim(mesg)) + endif + do n=1,2 ! Calculate density values with a wide enough stencil to estimate first and second derivatives ! with up to 6th order accuracy. Doing this twice with different sizes of perturbations allows diff --git a/src/equation_of_state/MOM_EOS_Jackett06.F90 b/src/equation_of_state/MOM_EOS_Jackett06.F90 index 3d13591bb8..119edee4f0 100644 --- a/src/equation_of_state/MOM_EOS_Jackett06.F90 +++ b/src/equation_of_state/MOM_EOS_Jackett06.F90 @@ -9,7 +9,7 @@ module MOM_EOS_Jackett06 public calculate_compress_Jackett06, calculate_density_Jackett06, calculate_spec_vol_Jackett06 public calculate_density_derivs_Jackett06, calculate_specvol_derivs_Jackett06 -public calculate_density_second_derivs_Jackett06 +public calculate_density_second_derivs_Jackett06, EoS_fit_range_Jackett06 !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity in practical salinity units ([PSU]), potential @@ -541,6 +541,28 @@ subroutine calculate_density_second_derivs_scalar_Jackett(T, S, P, drho_ds_ds, d end subroutine calculate_density_second_derivs_scalar_Jackett +!> Return the range of temperatures, salinities and pressures for which the Jackett et al. (2006) +!! equation of state has been fitted to observations. Care should be taken when applying this +!! equation of state outside of its fit range. +subroutine EoS_fit_range_Jackett06(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + ! Note that the actual fit range is given for the surface range of temperatures and salinities, + ! but Jackett et al. use a more limited range of properties at higher pressures. + if (present(T_min)) T_min = -4.5 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 8.5e7 + +end subroutine EoS_fit_range_Jackett06 + !> \namespace mom_eos_Jackett06 !! !! \section section_EOS_Jackett06 Jackett et al. 2006 (Hycom-25-term) equation of state @@ -551,6 +573,13 @@ end subroutine calculate_density_second_derivs_scalar_Jackett !! and so is commonly called the "17-term equation of state" there. Here the full expressions !! for the in situ densities are used. !! +!! The functional form of this equation of state includes terms proportional to salinity to the +!! 3/2 power. This introduces a singularity in the second derivative of density with salinity +!! at a salinity of 0, but this has been addressed here by setting a floor of 1e-8 PSU on the +!! salinity that is used in the denominator of these second derivative expressions. This value +!! was chosen to imply a contribution that is smaller than numerical roundoff in the expression for +!! density, which is the field for which the Jackett et al. equation of state was originally derived. +!! !! \subsection section_EOS_Jackett06_references References !! !! Jackett, D., T. McDougall, R. Feistel, D. Wright and S. Griffies (2006), diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index 33ea84721f..fb3a391cdd 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -10,7 +10,7 @@ module MOM_EOS_NEMO public calculate_compress_nemo, calculate_density_nemo public calculate_density_derivs_nemo public calculate_density_scalar_nemo, calculate_density_array_nemo -public calculate_density_second_derivs_nemo +public calculate_density_second_derivs_nemo, EoS_fit_range_NEMO !> Compute the in situ density of sea water [kg m-3], or its anomaly with respect to !! a reference density, from absolute salinity [g kg-1], conservative temperature [degC], @@ -584,6 +584,26 @@ subroutine calculate_density_second_derivs_scalar_NEMO(T, S, P, drho_ds_ds, drho end subroutine calculate_density_second_derivs_scalar_NEMO +!> Return the range of temperatures, salinities and pressures for which the Roquet et al. (2015) +!! expression for in situ density has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_NEMO(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_NEMO + !> \namespace mom_eos_NEMO !! !! \section section_EOS_NEMO NEMO equation of state diff --git a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 index 5a276065dd..3bad8ac579 100644 --- a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 +++ b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 @@ -10,7 +10,7 @@ module MOM_EOS_Roquet_Spv public calculate_compress_Roquet_SpV, calculate_density_Roquet_SpV, calculate_spec_vol_Roquet_SpV public calculate_density_derivs_Roquet_SpV, calculate_specvol_derivs_Roquet_SpV public calculate_density_scalar_Roquet_SpV, calculate_density_array_Roquet_SpV -public calculate_density_second_derivs_Roquet_SpV +public calculate_density_second_derivs_Roquet_SpV, EoS_fit_range_Roquet_SpV !> Compute the in situ density of sea water [kg m-3], or its anomaly with respect to !! a reference density, from absolute salinity [g kg-1], conservative temperature [degC], @@ -771,6 +771,26 @@ subroutine calculate_density_second_derivs_scalar_Roquet_SpV(T, S, P, drho_ds_ds end subroutine calculate_density_second_derivs_scalar_Roquet_SpV +!> Return the range of temperatures, salinities and pressures for which the Roquet et al. (2015) +!! expression for specific volume has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_Roquet_SpV(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Roquet_SpV + !> \namespace mom_eos_Roquet_SpV !! !! \section section_EOS_Roquet_SpV NEMO equation of state diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index 4c7483c068..22faa495b4 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -17,9 +17,8 @@ module MOM_EOS_TEOS10 implicit none ; private public calculate_compress_teos10, calculate_density_teos10, calculate_spec_vol_teos10 -public calculate_density_derivs_teos10 -public calculate_specvol_derivs_teos10 -public calculate_density_second_derivs_teos10 +public calculate_density_derivs_teos10, calculate_specvol_derivs_teos10 +public calculate_density_second_derivs_teos10, EoS_fit_range_teos10 public gsw_sp_from_sr, gsw_pt_from_ct !> Compute the in situ density of sea water ([kg m-3]), or its anomaly with respect to @@ -369,4 +368,25 @@ subroutine calculate_compress_teos10(T, S, pressure, rho, drho_dp, start, npts) enddo end subroutine calculate_compress_teos10 + +!> Return the range of temperatures, salinities and pressures for which the TEOS-10 +!! equation of state has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_teos10(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_teos10 + end module MOM_EOS_TEOS10 diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index ae9cf72aaa..984b4a7217 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -8,7 +8,7 @@ module MOM_EOS_UNESCO public calculate_compress_UNESCO, calculate_density_UNESCO, calculate_spec_vol_UNESCO public calculate_density_derivs_UNESCO, calculate_specvol_derivs_UNESCO public calculate_density_scalar_UNESCO, calculate_density_array_UNESCO -public calculate_density_second_derivs_UNESCO +public calculate_density_second_derivs_UNESCO, EoS_fit_range_UNESCO !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity [PSU], potential temperature [degC] and pressure [Pa], @@ -586,6 +586,26 @@ subroutine calculate_density_second_derivs_scalar_UNESCO(T, S, P, drho_ds_ds, dr end subroutine calculate_density_second_derivs_scalar_UNESCO +!> Return the range of temperatures, salinities and pressures for which Jackett and McDougall (1995) +!! refit the UNESCO equation of state has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_UNESCO(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.5 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_UNESCO + !> \namespace mom_eos_UNESCO !! !! \section section_EOS_UNESCO UNESCO (Jackett & McDougall) equation of state diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index ba73319423..14f40ac3f6 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -12,6 +12,7 @@ module MOM_EOS_Wright public calculate_compress_wright, calculate_density_wright, calculate_spec_vol_wright public calculate_density_derivs_wright, calculate_specvol_derivs_wright public calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy +public EoS_fit_range_Wright public int_density_dz_wright, int_spec_vol_dp_wright !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to @@ -548,6 +549,26 @@ subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) enddo end subroutine calculate_compress_wright +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_Wright(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 30.0 + if (present(S_min)) S_min = 28.0 + if (present(S_max)) S_max = 38.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 5.0e7 + +end subroutine EoS_fit_range_Wright + !> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure !! anomalies, which are required for calculating the finite-volume form pressure accelerations in a !! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index f20bd67759..6e05e51a70 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -11,7 +11,7 @@ module MOM_EOS_Wright_full public calculate_compress_wright_full, calculate_density_wright_full, calculate_spec_vol_wright_full public calculate_density_derivs_wright_full, calculate_specvol_derivs_wright_full -public calculate_density_second_derivs_wright_full +public calculate_density_second_derivs_wright_full, EoS_fit_range_Wright_full public int_density_dz_wright_full, int_spec_vol_dp_wright_full !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to @@ -442,6 +442,26 @@ subroutine calculate_compress_wright_full(T, S, pressure, rho, drho_dp, start, n enddo end subroutine calculate_compress_wright_full +!> Return the range of temperatures, salinities and pressures for which full-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_Wright_full(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 40.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Wright_full + !> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure !! anomalies, which are required for calculating the finite-volume form pressure accelerations in a !! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index eaf3998be7..8216c902a3 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -11,7 +11,7 @@ module MOM_EOS_Wright_red public calculate_compress_wright_red, calculate_density_wright_red, calculate_spec_vol_wright_red public calculate_density_derivs_wright_red, calculate_specvol_derivs_wright_red -public calculate_density_second_derivs_wright_red +public calculate_density_second_derivs_wright_red, EoS_fit_range_Wright_red public int_density_dz_wright_red, int_spec_vol_dp_wright_red !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to @@ -442,6 +442,26 @@ subroutine calculate_compress_wright_red(T, S, pressure, rho, drho_dp, start, np enddo end subroutine calculate_compress_wright_red +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_Wright_red(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 30.0 + if (present(S_min)) S_min = 28.0 + if (present(S_max)) S_max = 38.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 5.0e7 + +end subroutine EoS_fit_range_Wright_red + !> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure !! anomalies, which are required for calculating the finite-volume form pressure accelerations in a !! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index dc3a5f59b2..ee53b63bb6 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -13,7 +13,7 @@ module MOM_EOS_linear public calculate_density_derivs_linear, calculate_density_derivs_scalar_linear public calculate_specvol_derivs_linear public calculate_density_scalar_linear, calculate_density_array_linear -public calculate_density_second_derivs_linear +public calculate_density_second_derivs_linear, EoS_fit_range_linear public int_density_dz_linear, int_spec_vol_dp_linear ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -320,6 +320,26 @@ subroutine calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts,& enddo end subroutine calculate_compress_linear +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_linear(T_min, T_max, S_min, S_max, p_min, p_max) + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: S_max !< The maximum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -273.0 + if (present(T_max)) T_max = 100.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 1000.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e9 + +end subroutine EoS_fit_range_linear + !> This subroutine calculates analytical and nearly-analytical integrals of !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. From 3731c276c6a5659a00c6e2a0d30c806b6be65fb5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 12 Mar 2023 09:07:55 -0400 Subject: [PATCH 59/91] Do not include MOM_memory.h in EoS modules Removed unused and unnecessary #include statements from 5 equation of state modules. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 2 -- src/equation_of_state/MOM_EOS_Wright.F90 | 2 -- src/equation_of_state/MOM_EOS_Wright_full.F90 | 2 -- src/equation_of_state/MOM_EOS_Wright_red.F90 | 2 -- src/equation_of_state/MOM_EOS_linear.F90 | 2 -- 5 files changed, 10 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 1628ceb594..eee686e129 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -58,8 +58,6 @@ module MOM_EOS implicit none ; private -#include - public EOS_domain public EOS_init public EOS_manual_init diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 14f40ac3f6..25ae9219a8 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -7,8 +7,6 @@ module MOM_EOS_Wright implicit none ; private -#include - public calculate_compress_wright, calculate_density_wright, calculate_spec_vol_wright public calculate_density_derivs_wright, calculate_specvol_derivs_wright public calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 6e05e51a70..8b7fe6751d 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -7,8 +7,6 @@ module MOM_EOS_Wright_full implicit none ; private -#include - public calculate_compress_wright_full, calculate_density_wright_full, calculate_spec_vol_wright_full public calculate_density_derivs_wright_full, calculate_specvol_derivs_wright_full public calculate_density_second_derivs_wright_full, EoS_fit_range_Wright_full diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index 8216c902a3..4d5de35a1f 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -7,8 +7,6 @@ module MOM_EOS_Wright_red implicit none ; private -#include - public calculate_compress_wright_red, calculate_density_wright_red, calculate_spec_vol_wright_red public calculate_density_derivs_wright_red, calculate_specvol_derivs_wright_red public calculate_density_second_derivs_wright_red, EoS_fit_range_Wright_red diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index ee53b63bb6..1899103f5d 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -7,8 +7,6 @@ module MOM_EOS_linear implicit none ; private -#include - public calculate_compress_linear, calculate_density_linear, calculate_spec_vol_linear public calculate_density_derivs_linear, calculate_density_derivs_scalar_linear public calculate_specvol_derivs_linear From ed4623b43fbd2d7d65cd2de80e8be0902e68a425 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 12 Mar 2023 12:27:55 -0400 Subject: [PATCH 60/91] *Refactor calculate_specific_vol_wright_full Refactored the specific volume calculations for the WRIGHT_FULL and WRIGHT_RED equations of states for simplicity or to reduce the impacts of roundoff when removing a reference value. Also added code to multiply by the reciprocal of the denominator rather than dividing in several places in the int_spec_vol_dp routines for these same two equations of state, both for efficiency and greater consistency across optimization levels. These changes are mathematically equivalent but will change answers at roundoff with these two equations of state, but they are so new that they can not have been used yet. --- src/equation_of_state/MOM_EOS_Wright_full.F90 | 50 ++++++++++++------- src/equation_of_state/MOM_EOS_Wright_red.F90 | 50 ++++++++++++------- 2 files changed, 64 insertions(+), 36 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 8b7fe6751d..3f00a92cef 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -179,20 +179,30 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, ! Local variables real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] real :: p0 ! The pressure offset in the Wright EOS [Pa] - real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] integer :: j - do j=start,start+npts-1 - al0 = a0 + (a1*T(j) + a2*S(j)) - p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) - lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) - - if (present(spv_ref)) then - specvol(j) = (lambda + (al0 - spv_ref)*(pressure(j) + p0)) / (pressure(j) + p0) - else - specvol(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) - endif - enddo + if (present(spv_ref)) then + lam_000 = c0 + (a0 - spv_ref)*b0 + do j=start,start+npts-1 + al_TS = a1*T(j) + a2*S(j) + p_TSp = pressure(j) + (b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j)))) + lambda = lam_000 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + specvol(j) = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + enddo + else + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + specvol(j) = al0 + lambda / (pressure(j) + p0) + enddo + endif end subroutine calculate_spec_vol_array_wright !> Return the thermal/haline expansion coefficients for 1-d array inputs and outputs @@ -793,6 +803,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: I_pterm ! The inverse of p0 plus p_ave [T2 R-1 L-2 ~> Pa-1]. real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. @@ -866,9 +877,10 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dp = p_b(i,j) - p_t(i,j) p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + I_pterm = 1.0 / (p0 + p_ave) - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - alpha_anom = (al0 - spv_ref) + lambda / (p0 + p_ave) + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + alpha_anom = (al0 - spv_ref) + lambda * I_pterm rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) dza(i,j) = alpha_anom*dp + 2.0*eps*rem if (present(intp_dza)) & @@ -906,9 +918,10 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + I_pterm = 1.0 / (p0 + p_ave) - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Boole's rule to integrate the values. @@ -947,9 +960,10 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + I_pterm = 1.0 / (p0 + p_ave) - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Boole's rule to integrate the values. diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index 4d5de35a1f..cf78ce2211 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -179,20 +179,30 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, ! Local variables real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] real :: p0 ! The pressure offset in the Wright EOS [Pa] - real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] integer :: j - do j=start,start+npts-1 - al0 = a0 + (a1*T(j) + a2*S(j)) - p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) - lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) - - if (present(spv_ref)) then - specvol(j) = (lambda + (al0 - spv_ref)*(pressure(j) + p0)) / (pressure(j) + p0) - else - specvol(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) - endif - enddo + if (present(spv_ref)) then + lam_000 = c0 + (a0 - spv_ref)*b0 + do j=start,start+npts-1 + al_TS = a1*T(j) + a2*S(j) + p_TSp = pressure(j) + (b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j)))) + lambda = lam_000 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + specvol(j) = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + enddo + else + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + specvol(j) = al0 + lambda / (pressure(j) + p0) + enddo + endif end subroutine calculate_spec_vol_array_wright !> Return the thermal/haline expansion coefficients for 1-d array inputs and outputs @@ -793,6 +803,7 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: I_pterm ! The inverse of p0 plus p_ave [T2 R-1 L-2 ~> Pa-1]. real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. @@ -866,9 +877,10 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dp = p_b(i,j) - p_t(i,j) p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + I_pterm = 1.0 / (p0 + p_ave) - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - alpha_anom = (al0 - spv_ref) + lambda / (p0 + p_ave) + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + alpha_anom = (al0 - spv_ref) + lambda * I_pterm rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) dza(i,j) = alpha_anom*dp + 2.0*eps*rem if (present(intp_dza)) & @@ -906,9 +918,10 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + I_pterm = 1.0 / (p0 + p_ave) - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Boole's rule to integrate the values. @@ -947,9 +960,10 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + I_pterm = 1.0 / (p0 + p_ave) - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = ((al0 - spv_ref) + lambda / (p0 + p_ave))*dp + 2.0*eps* & + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Boole's rule to integrate the values. From 4a3b6ac39fd2cd6e149350a3d3489dc8a2024986 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Mar 2023 10:37:51 -0400 Subject: [PATCH 61/91] +Renamed MOM_EOS_NEMO to MOM_EOS_Roquet_rho Renamed the module MOM_EOS_NEMO to MOM_EOS_Roquet_rho to more accurately reflect its provenance, although setting either EQN_OF_STATE = NEMO or EQN_OF_STATE = ROQUET_RHO will still work for using this code. All answers are bitwise identical, and previous input files will still work, but there are some minor changes in the MOM_parameter_doc files. --- src/equation_of_state/MOM_EOS.F90 | 91 ++++++++++--------- ...OM_EOS_NEMO.F90 => MOM_EOS_Roquet_rho.F90} | 89 +++++++++--------- 2 files changed, 87 insertions(+), 93 deletions(-) rename src/equation_of_state/{MOM_EOS_NEMO.F90 => MOM_EOS_Roquet_rho.F90} (93%) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index eee686e129..1a1668e63b 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -34,10 +34,10 @@ module MOM_EOS use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_specvol_derivs_UNESCO use MOM_EOS_UNESCO, only : calculate_density_second_derivs_UNESCO, calculate_compress_unesco use MOM_EOS_UNESCO, only : EoS_fit_range_UNESCO -use MOM_EOS_NEMO, only : calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_density_derivs_nemo -use MOM_EOS_NEMO, only : calculate_density_second_derivs_NEMO, calculate_compress_nemo -use MOM_EOS_NEMO, only : EoS_fit_range_NEMO +use MOM_EOS_Roquet_rho, only : calculate_density_Roquet_rho +use MOM_EOS_Roquet_rho, only : calculate_density_derivs_Roquet_rho +use MOM_EOS_Roquet_rho, only : calculate_density_second_derivs_Roquet_rho, calculate_compress_Roquet_rho +use MOM_EOS_Roquet_rho, only : EoS_fit_range_Roquet_rho use MOM_EOS_Roquet_SpV, only : calculate_density_Roquet_SpV, calculate_spec_vol_Roquet_SpV use MOM_EOS_Roquet_SpV, only : calculate_density_derivs_Roquet_SpV, calculate_specvol_derivs_Roquet_SpV use MOM_EOS_Roquet_SpV, only : calculate_compress_Roquet_SpV, calculate_density_second_derivs_Roquet_SpV @@ -177,7 +177,7 @@ module MOM_EOS integer, parameter, public :: EOS_WRIGHT_FULL = 4 !< A named integer specifying an equation of state integer, parameter, public :: EOS_WRIGHT_RED = 5 !< A named integer specifying an equation of state integer, parameter, public :: EOS_TEOS10 = 6 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_NEMO = 7 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_ROQUET_RHO = 7 !< A named integer specifying an equation of state integer, parameter, public :: EOS_ROQUET_SPV = 8 !< A named integer specifying an equation of state integer, parameter, public :: EOS_JACKETT06 = 9 !< A named integer specifying an equation of state @@ -293,8 +293,8 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r case (EOS_UNESCO) call calculate_density_second_derivs_UNESCO(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_NEMO) - call calculate_density_second_derivs_NEMO(T_scale*T, S_scale*S, p_scale*pressure, & + case (EOS_ROQUET_RHO) + call calculate_density_second_derivs_Roquet_rho(T_scale*T, S_scale*S, p_scale*pressure, & d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) case (EOS_ROQUET_SPV) call calculate_density_second_derivs_Roquet_SpV(T_scale*T, S_scale*S, p_scale*pressure, & @@ -347,8 +347,8 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re call calculate_density_wright_red(T, S, pressure, rho, start, npts, rho_ref) case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_ROQUET_RHO) + call calculate_density_Roquet_rho(T, S, pressure, rho, start, npts, rho_ref) case (EOS_ROQUET_SPV) call calculate_density_Roquet_SpV(T, S, pressure, rho, start, npts, rho_ref) case (EOS_JACKETT06) @@ -418,9 +418,9 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh call calculate_density_UNESCO(T, S, pressure, rho, start, npts, rho_ref) call calculate_density_second_derivs_UNESCO(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_NEMO) - call calculate_density_NEMO(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_NEMO(T, S, pressure, d2RdSS, d2RdST, & + case (EOS_ROQUET_RHO) + call calculate_density_Roquet_rho(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_Roquet_rho(T, S, pressure, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, start, npts) case (EOS_ROQUET_SPV) call calculate_density_Roquet_SpV(T, S, pressure, rho, start, npts, rho_ref) @@ -586,9 +586,9 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, call calculate_density_UNESCO(Ta, Sa, pres, rho, is, npts, rho_reference) call calculate_density_second_derivs_UNESCO(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_NEMO) - call calculate_density_NEMO(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_NEMO(Ta, Sa, pres, d2RdSS, d2RdST, & + case (EOS_ROQUET_RHO) + call calculate_density_Roquet_rho(Ta, Sa, pres, rho, is, npts, rho_reference) + call calculate_density_second_derivs_Roquet_rho(Ta, Sa, pres, d2RdSS, d2RdST, & d2RdTT, d2RdSp, d2RdTP, is, npts) case (EOS_ROQUET_SPV) call calculate_density_Roquet_SpV(Ta, Sa, pres, rho, is, npts, rho_reference) @@ -652,8 +652,8 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s call calculate_spec_vol_wright_red(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_TEOS10) call calculate_spec_vol_teos10(T, S, pressure, specvol, start, npts, spv_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) + case (EOS_ROQUET_RHO) + call calculate_density_Roquet_rho(T, S, pressure, rho, start, npts) if (present(spv_ref)) then specvol(:) = 1.0 / rho(:) - spv_ref else @@ -947,8 +947,8 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star call calculate_density_derivs_wright_red(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_TEOS10) call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_NEMO) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_ROQUET_RHO) + call calculate_density_derivs_Roquet_rho(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_ROQUET_SPV) call calculate_density_derivs_Roquet_SpV(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_JACKETT06) @@ -1133,8 +1133,8 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_UNESCO) call calculate_density_second_derivs_UNESCO(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) - case (EOS_NEMO) - call calculate_density_second_derivs_NEMO(T, S, pressure, drho_dS_dS, drho_dS_dT, & + case (EOS_ROQUET_RHO) + call calculate_density_second_derivs_Roquet_rho(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_ROQUET_SPV) call calculate_density_second_derivs_Roquet_SpV(T, S, pressure, drho_dS_dS, drho_dS_dT, & @@ -1175,8 +1175,8 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_UNESCO) call calculate_density_second_derivs_UNESCO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) - case (EOS_NEMO) - call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + case (EOS_ROQUET_RHO) + call calculate_density_second_derivs_Roquet_rho(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_ROQUET_SpV) call calculate_density_second_derivs_Roquet_SpV(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & @@ -1271,8 +1271,8 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr case (EOS_UNESCO) call calculate_density_second_derivs_UNESCO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) - case (EOS_NEMO) - call calculate_density_second_derivs_NEMO(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + case (EOS_ROQUET_RHO) + call calculate_density_second_derivs_Roquet_rho(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_ROQUET_SPV) call calculate_density_second_derivs_Roquet_SpV(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & @@ -1349,9 +1349,9 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start call calculate_specvol_derivs_wright_red(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_TEOS10) call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_ROQUET_RHO) + call calculate_density_Roquet_rho(T, S, pressure, rho, start, npts) + call calculate_density_derivs_Roquet_rho(T, S, pressure, drho_dT, drho_dS, start, npts) do j=start,start+npts-1 dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) @@ -1466,8 +1466,8 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) call calculate_compress_wright_red(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_TEOS10) call calculate_compress_teos10(Ta, Sa, pres, rho, drho_dp, is, npts) - case (EOS_NEMO) - call calculate_compress_nemo(Ta, Sa, pres, rho, drho_dp, is, npts) + case (EOS_ROQUET_RHO) + call calculate_compress_Roquet_rho(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_ROQUET_SpV) call calculate_compress_Roquet_SpV(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_JACKETT06) @@ -1538,8 +1538,8 @@ subroutine EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) call EoS_fit_range_Wright_red(T_min, T_max, S_min, S_max, p_min, p_max) case (EOS_TEOS10) call EoS_fit_range_TEOS10(T_min, T_max, S_min, S_max, p_min, p_max) - case (EOS_NEMO) - call EoS_fit_range_NEMO(T_min, T_max, S_min, S_max, p_min, p_max) + case (EOS_ROQUET_RHO) + call EoS_fit_range_Roquet_rho(T_min, T_max, S_min, S_max, p_min, p_max) case (EOS_ROQUET_SpV) call EoS_fit_range_Roquet_SpV(T_min, T_max, S_min, S_max, p_min, p_max) case (EOS_JACKETT06) @@ -1813,9 +1813,9 @@ subroutine EOS_init(param_file, EOS, US) case (EOS_TEOS10_STRING) EOS%form_of_EOS = EOS_TEOS10 case (EOS_NEMO_STRING) - EOS%form_of_EOS = EOS_NEMO + EOS%form_of_EOS = EOS_ROQUET_RHO case (EOS_ROQUET_RHO_STRING) - EOS%form_of_EOS = EOS_NEMO + EOS%form_of_EOS = EOS_ROQUET_RHO case (EOS_ROQUET_SPV_STRING) EOS%form_of_EOS = EOS_ROQUET_SPV case (EOS_JACKETT06_STRING) @@ -1857,7 +1857,7 @@ subroutine EOS_init(param_file, EOS, US) "code for the integrals of density.", default=EOS_quad_default) TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING - if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO .or. & + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & EOS%form_of_EOS == EOS_ROQUET_SPV)) & TFREEZE_DEFAULT = TFREEZE_TEOS10_STRING call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & @@ -1894,9 +1894,10 @@ subroutine EOS_init(param_file, EOS, US) units="deg C Pa-1", default=0.0) endif - if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_NEMO .or. EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & + EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & (EOS%form_of_TFreeze /= TFREEZE_TEOS10)) then - call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO or EOS_ROQUET_SPV "//& + call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_ROQUET_RHO or EOS_ROQUET_SPV "//& "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") endif @@ -1987,7 +1988,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) real :: gsw_ct_from_pt ! Conservative temperature after conversion from potential temperature [degC] integer :: i, j, k - if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO) .and. & + if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_ROQUET_RHO) .and. & (EOS%form_of_EOS /= EOS_ROQUET_SPV)) return do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec @@ -2176,10 +2177,10 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_NEMO) - fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "NEMO", & + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_RHO) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "ROQUET_RHO", & rho_check=1027.42385663668*EOS_tmp%kg_m3_to_R) - if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_RHO EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) @@ -2205,11 +2206,11 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_NEMO) - fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "NEMO", & + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_RHO) + fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "ROQUET_RHO", & rho_check=1027.45140117152*EOS_tmp%kg_m3_to_R) ! The corresponding check value published by Roquet et al. (2015) is 1027.45140 [kg m-3]. - if (verbose .and. fail) call MOM_error(WARNING, "NEMO EOS has failed some self-consistency tests.") + if (verbose .and. fail) call MOM_error(WARNING, "Roquet_rho EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) @@ -2578,5 +2579,5 @@ end module MOM_EOS !> \namespace mom_eos !! !! The MOM_EOS module is a wrapper for various equations of state (i.e. Linear, Wright, -!! Wright_full, Wright_red, UNESCO, TEOS10, Roquet_SpV or NEMO) and provides a uniform +!! Wright_full, Wright_red, UNESCO, TEOS10, Roquet_SpV or Roquet_rho) and provides a uniform !! interface to the rest of the model independent of which equation of state is being used. diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 similarity index 93% rename from src/equation_of_state/MOM_EOS_NEMO.F90 rename to src/equation_of_state/MOM_EOS_Roquet_rho.F90 index fb3a391cdd..75276ac25b 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 @@ -1,5 +1,5 @@ -!> The equation of state using the expressions of Roquet et al. that are used in NEMO -module MOM_EOS_NEMO +!> The equation of state using the expressions of Roquet et al. (2015) that are used in NEMO +module MOM_EOS_Roquet_rho ! This file is part of MOM6. See LICENSE.md for the license. @@ -7,32 +7,32 @@ module MOM_EOS_NEMO implicit none ; private -public calculate_compress_nemo, calculate_density_nemo -public calculate_density_derivs_nemo -public calculate_density_scalar_nemo, calculate_density_array_nemo -public calculate_density_second_derivs_nemo, EoS_fit_range_NEMO +public calculate_compress_Roquet_rho, calculate_density_Roquet_rho +public calculate_density_derivs_Roquet_rho +public calculate_density_scalar_Roquet_rho, calculate_density_array_Roquet_rho +public calculate_density_second_derivs_Roquet_rho, EoS_fit_range_Roquet_rho !> Compute the in situ density of sea water [kg m-3], or its anomaly with respect to !! a reference density, from absolute salinity [g kg-1], conservative temperature [degC], !! and pressure [Pa], using the expressions for density from Roquet et al. (2015) -interface calculate_density_nemo - module procedure calculate_density_scalar_nemo, calculate_density_array_nemo -end interface calculate_density_nemo +interface calculate_density_Roquet_rho + module procedure calculate_density_scalar_Roquet_rho, calculate_density_array_Roquet_rho +end interface calculate_density_Roquet_rho !> For a given thermodynamic state, return the derivatives of density with conservative temperature !! and absolute salinity, using the expressions for density from Roquet et al. (2015) -interface calculate_density_derivs_nemo - module procedure calculate_density_derivs_scalar_nemo, calculate_density_derivs_array_nemo -end interface calculate_density_derivs_nemo +interface calculate_density_derivs_Roquet_rho + module procedure calculate_density_derivs_scalar_Roquet_rho, calculate_density_derivs_array_Roquet_rho +end interface calculate_density_derivs_Roquet_rho !> Compute the second derivatives of density with various combinations of temperature, !! salinity, and pressure using the expressions for density from Roquet et al. (2015) -interface calculate_density_second_derivs_nemo - module procedure calculate_density_second_derivs_scalar_nemo, calculate_density_second_derivs_array_nemo -end interface calculate_density_second_derivs_nemo +interface calculate_density_second_derivs_Roquet_rho + module procedure calculate_density_second_derivs_scalar_Roquet_rho, calculate_density_second_derivs_array_Roquet_rho +end interface calculate_density_second_derivs_Roquet_rho real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar [dbar Pa-1] -!>@{ Parameters in the NEMO (Roquet density) equation of state +!>@{ Parameters in the Roquet_rho (Roquet density) equation of state real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] real, parameter :: r1_T0 = 1./40. ! The inverse of a plausible range of oceanic temperatures [degC-1] @@ -177,7 +177,7 @@ module MOM_EOS_NEMO !> This subroutine computes the in situ density of sea water (rho in [kg m-3]) !! from absolute salinity (S [g kg-1]), conservative temperature (T [degC]) !! and pressure [Pa], using the density polynomial fit EOS from Roquet et al. (2015). -subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) +subroutine calculate_density_scalar_Roquet_rho(T, S, pressure, rho, rho_ref) real, intent(in) :: T !< Conservative temperature [degC] real, intent(in) :: S !< Absolute salinity [g kg-1] real, intent(in) :: pressure !< Pressure [Pa] @@ -193,15 +193,15 @@ subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) S0(1) = S pressure0(1) = pressure - call calculate_density_array_nemo(T0, S0, pressure0, rho0, 1, 1, rho_ref) + call calculate_density_array_Roquet_rho(T0, S0, pressure0, rho0, 1, 1, rho_ref) rho = rho0(1) -end subroutine calculate_density_scalar_nemo +end subroutine calculate_density_scalar_Roquet_rho !> This subroutine computes an array of in situ densities of sea water (rho in [kg m-3]) !! from absolute salinity (S [g kg-1]), conservative temperature (T [degC]), and pressure !! [Pa], using the density polynomial fit EOS from Roquet et al. (2015). -subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_ref) +subroutine calculate_density_array_Roquet_rho(T, S, pressure, rho, start, npts, rho_ref) real, dimension(:), intent(in) :: T !< Conservative temperature [degC] real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] @@ -225,8 +225,7 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] integer :: j - ! The following algorithm was published by Roquet et al. (2015), intended for use - ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. do j=start,start+npts-1 ! Conversions to the units used here. zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] @@ -262,11 +261,11 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re rho(j) = rhoTS + rho00p ! In situ density [kg m-3] enddo -end subroutine calculate_density_array_nemo +end subroutine calculate_density_array_Roquet_rho !> For a given thermodynamic state, calculate the derivatives of density with conservative !! temperature and absolute salinity, using the density polynomial fit EOS from Roquet et al. (2015). -subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) +subroutine calculate_density_derivs_array_Roquet_rho(T, S, pressure, drho_dT, drho_dS, start, npts) real, intent(in), dimension(:) :: T !< Conservative temperature [degC] real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] real, intent(in), dimension(:) :: pressure !< Pressure [Pa] @@ -341,10 +340,10 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, drho_dS(j) = (dRdzs0 + zp*(dRdzs1 + zp*(dRdzs2 + zp * dRdzs3))) / zs enddo -end subroutine calculate_density_derivs_array_nemo +end subroutine calculate_density_derivs_array_Roquet_rho !> Wrapper to calculate_density_derivs_array for scalar inputs -subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds) +subroutine calculate_density_derivs_scalar_Roquet_rho(T, S, pressure, drho_dt, drho_ds) real, intent(in) :: T !< Conservative temperature [degC] real, intent(in) :: S !< Absolute salinity [g kg-1] real, intent(in) :: pressure !< Pressure [Pa] @@ -365,16 +364,16 @@ subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds S0(1) = S pressure0(1) = pressure - call calculate_density_derivs_array_nemo(T0, S0, pressure0, drdt0, drds0, 1, 1) + call calculate_density_derivs_array_Roquet_rho(T0, S0, pressure0, drdt0, drds0, 1, 1) drho_dt = drdt0(1) drho_ds = drds0(1) -end subroutine calculate_density_derivs_scalar_nemo +end subroutine calculate_density_derivs_scalar_Roquet_rho !> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility !! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), !! conservative temperature (T [degC]), and pressure [Pa], using the density polynomial !! fit EOS from Roquet et al. (2015). -subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) +subroutine calculate_compress_Roquet_rho(T, S, pressure, rho, drho_dp, start, npts) real, intent(in), dimension(:) :: T !< Conservative temperature [degC] real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] real, intent(in), dimension(:) :: pressure !< Pressure [Pa] @@ -401,8 +400,7 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] integer :: j - ! The following algorithm was published by Roquet et al. (2015), intended for use - ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. do j=start,start+npts-1 ! Conversions to the units used here. zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] @@ -441,11 +439,11 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) drho_dp(j) = (drhoTS_dp + drho00p_dp) * (Pa2db*r1_P0) ! Compressibility [s2 m-2] enddo -end subroutine calculate_compress_nemo +end subroutine calculate_compress_Roquet_rho !> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. -subroutine calculate_density_second_derivs_array_NEMO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & +subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp, start, npts) real, dimension(:), intent(in ) :: T !< Conservative temperature [degC] real, dimension(:), intent(in ) :: S !< Absolute salinity [PSU] @@ -538,13 +536,13 @@ subroutine calculate_density_second_derivs_array_NEMO(T, S, P, drho_ds_ds, drho_ drho_dt_dp(j) = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * (Pa2db*r1_P0* r1_T0) enddo -end subroutine calculate_density_second_derivs_array_NEMO +end subroutine calculate_density_second_derivs_array_Roquet_rho !> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. !! !! The scalar version of calculate_density_second_derivs promotes scalar inputs to 1-element array !! and then demotes the output back to a scalar -subroutine calculate_density_second_derivs_scalar_NEMO(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & +subroutine calculate_density_second_derivs_scalar_Roquet_rho(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp) real, intent(in ) :: T !< Conservative temperature [degC] real, intent(in ) :: S !< Absolute salinity [PSU] @@ -575,19 +573,19 @@ subroutine calculate_density_second_derivs_scalar_NEMO(T, S, P, drho_ds_ds, drho T0(1) = T S0(1) = S P0(1) = P - call calculate_density_second_derivs_array_NEMO(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) + call calculate_density_second_derivs_array_Roquet_rho(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) drho_ds_ds = drdsds(1) drho_ds_dt = drdsdt(1) drho_dt_dt = drdtdt(1) drho_ds_dp = drdsdp(1) drho_dt_dp = drdtdp(1) -end subroutine calculate_density_second_derivs_scalar_NEMO +end subroutine calculate_density_second_derivs_scalar_Roquet_rho !> Return the range of temperatures, salinities and pressures for which the Roquet et al. (2015) !! expression for in situ density has been fitted to observations. Care should be taken when !! applying this equation of state outside of its fit range. -subroutine EoS_fit_range_NEMO(T_min, T_max, S_min, S_max, p_min, p_max) +subroutine EoS_fit_range_Roquet_rho(T_min, T_max, S_min, S_max, p_min, p_max) real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] @@ -602,11 +600,11 @@ subroutine EoS_fit_range_NEMO(T_min, T_max, S_min, S_max, p_min, p_max) if (present(p_min)) p_min = 0.0 if (present(p_max)) p_max = 1.0e8 -end subroutine EoS_fit_range_NEMO +end subroutine EoS_fit_range_Roquet_rho -!> \namespace mom_eos_NEMO +!> \namespace mom_eos_Roquet_rho !! -!! \section section_EOS_NEMO NEMO equation of state +!! \section section_EOS_Roquet_rho Roquet_rho equation of state !! !! Fabien Roquet and colleagues developed this equation of state using a simple polynomial fit !! to the TEOS-10 equation of state, for efficiency when used in the NEMO ocean model. Fabien @@ -617,15 +615,10 @@ end subroutine EoS_fit_range_NEMO !! observational uncertainty with a polynomial form that can be evaluated quickly despite having !! 52 terms. !! -!! The NEMO label used to describe this equation of state reflects that it was used in the NEMO -!! ocean model before it was used in MOM6, but it probably should be described as the Roquet -!! equation of state. However, these algorithms, especially as modified here, are not from -!! the standard NEMO codebase. -!! -!! \subsection section_EOS_NEMO_references References +!! \subsection section_EOS_Roquet_rho_references References !! !! Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015: !! Accurate polynomial expressions for the density and specific volume !! of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. -end module MOM_EOS_NEMO +end module MOM_EOS_Roquet_rho From ae46d7da0e8927b32abb1ea1d544c4ee9a06e8ce Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Mar 2023 17:23:13 -0400 Subject: [PATCH 62/91] *Avoid re-rescaling T and p in MOM_EOS_Roquet_rho Refactored MOM_EOS_Roquet_rho and MOM_EOS_Roquet_SpV to work directly with conservative temperatures in [degC] and pressures in [Pa] rather than normalizing them as in the original Roquet publication. However, the coefficients are still set using the values directly copied from that paper, but rescaled where they are declared as parameters, enabling (or requiring) compilers to precalculate them during compilation. These changes are mathematically equivalent but will change answers at roundoff with these two equations of state, but they are not believed to be in use yet. --- src/equation_of_state/MOM_EOS_Roquet_SpV.F90 | 431 +++++++++--------- src/equation_of_state/MOM_EOS_Roquet_rho.F90 | 451 ++++++++++--------- 2 files changed, 447 insertions(+), 435 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 index 3bad8ac579..b6133442db 100644 --- a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 +++ b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 @@ -40,145 +40,148 @@ module MOM_EOS_Roquet_Spv module procedure calculate_density_second_derivs_array_Roquet_SpV end interface calculate_density_second_derivs_Roquet_SpV -real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar [dbar Pa-1] +real, parameter :: Pa2kb = 1.e-8 !< Conversion factor between Pa and kbar [kbar Pa-1] !>@{ Parameters in the Roquet specific volume polynomial equation of state -real, parameter :: rdeltaS = 24. ! An offset to salinity before taking its square root [g kg-1] -real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] -real, parameter :: r1_T0 = 1./40. ! The inverse of a plausible range of oceanic temperatures [degC-1] -real, parameter :: r1_P0 = 1.e-4 ! The inverse of a plausible range of oceanic pressures [dbar-1] -real, parameter :: V00 = -4.4015007269e-05 ! Contribution to SpV00p proportional to zp [m3 kg-1] -real, parameter :: V01 = 6.9232335784e-06 ! Contribution to SpV00p proportional to zp**2 [m3 kg-1] -real, parameter :: V02 = -7.5004675975e-07 ! Contribution to SpV00p proportional to zp**3 [m3 kg-1] -real, parameter :: V03 = 1.7009109288e-08 ! Contribution to SpV00p proportional to zp**4 [m3 kg-1] -real, parameter :: V04 = -1.6884162004e-08 ! Contribution to SpV00p proportional to zp**5 [m3 kg-1] -real, parameter :: V05 = 1.9613503930e-09 ! Contribution to SpV00p proportional to zp**6 [m3 kg-1] - -! The following terms are contributions to specific volume as a function of the normalized square root of salinity -! with an offset (zs), temperature (zt) and pressure (zp), with a contribution SPVabc * zs**a * zt**b * zp**c -real, parameter :: SPV000 = 1.0772899069e-03 ! A constant specific volume (SpV) contribution [m3 kg-1] -real, parameter :: SPV100 = -3.1263658781e-04 ! Coefficient of SpV proportional to zs [m3 kg-1] -real, parameter :: SPV200 = 6.7615860683e-04 ! Coefficient of SpV proportional to zs**2 [m3 kg-1] -real, parameter :: SPV300 = -8.6127884515e-04 ! Coefficient of SpV proportional to zs**3 [m3 kg-1] -real, parameter :: SPV400 = 5.9010812596e-04 ! Coefficient of SpV proportional to zs**4 [m3 kg-1] -real, parameter :: SPV500 = -2.1503943538e-04 ! Coefficient of SpV proportional to zs**5 [m3 kg-1] -real, parameter :: SPV600 = 3.2678954455e-05 ! Coefficient of SpV proportional to zs**6 [m3 kg-1] -real, parameter :: SPV010 = -1.4949652640e-05 ! Coefficient of SpV proportional to zt [m3 kg-1] -real, parameter :: SPV110 = 3.1866349188e-05 ! Coefficient of SpV proportional to zs * zt [m3 kg-1] -real, parameter :: SPV210 = -3.8070687610e-05 ! Coefficient of SpV proportional to zs**2 * zt [m3 kg-1] -real, parameter :: SPV310 = 2.9818473563e-05 ! Coefficient of SpV proportional to zs**3 * zt [m3 kg-1] -real, parameter :: SPV410 = -1.0011321965e-05 ! Coefficient of SpV proportional to zs**4 * zt [m3 kg-1] -real, parameter :: SPV510 = 1.0751931163e-06 ! Coefficient of SpV proportional to zs**5 * zt [m3 kg-1] -real, parameter :: SPV020 = 2.7546851539e-05 ! Coefficient of SpV proportional to zt**2 [m3 kg-1] -real, parameter :: SPV120 = -3.6597334199e-05 ! Coefficient of SpV proportional to zs * zt**2 [m3 kg-1] -real, parameter :: SPV220 = 3.4489154625e-05 ! Coefficient of SpV proportional to zs**2 * zt**2 [m3 kg-1] -real, parameter :: SPV320 = -1.7663254122e-05 ! Coefficient of SpV proportional to zs**3 * zt**2 [m3 kg-1] -real, parameter :: SPV420 = 3.5965131935e-06 ! Coefficient of SpV proportional to zs**4 * zt**2 [m3 kg-1] -real, parameter :: SPV030 = -1.6506828994e-05 ! Coefficient of SpV proportional to zt**3 [m3 kg-1] -real, parameter :: SPV130 = 2.4412359055e-05 ! Coefficient of SpV proportional to zs * zt**3 [m3 kg-1] -real, parameter :: SPV230 = -1.4606740723e-05 ! Coefficient of SpV proportional to zs**2 * zt**3 [m3 kg-1] -real, parameter :: SPV330 = 2.3293406656e-06 ! Coefficient of SpV proportional to zs**3 * zt**3 [m3 kg-1] -real, parameter :: SPV040 = 6.7896174634e-06 ! Coefficient of SpV proportional to zt**4 [m3 kg-1] -real, parameter :: SPV140 = -8.7951832993e-06 ! Coefficient of SpV proportional to zs * zt**4 [m3 kg-1] -real, parameter :: SPV240 = 4.4249040774e-06 ! Coefficient of SpV proportional to zs**2 * zt**4 [m3 kg-1] -real, parameter :: SPV050 = -7.2535743349e-07 ! Coefficient of SpV proportional to zt**5 [m3 kg-1] -real, parameter :: SPV150 = -3.4680559205e-07 ! Coefficient of SpV proportional to zs * zt**5 [m3 kg-1] -real, parameter :: SPV060 = 1.9041365570e-07 ! Coefficient of SpV proportional to zt**6 [m3 kg-1] -real, parameter :: SPV001 = -1.6889436589e-05 ! Coefficient of SpV proportional to zp [m3 kg-1] -real, parameter :: SPV101 = 2.1106556158e-05 ! Coefficient of SpV proportional to zs * zp [m3 kg-1] -real, parameter :: SPV201 = -2.1322804368e-05 ! Coefficient of SpV proportional to zs**2 * zp [m3 kg-1] -real, parameter :: SPV301 = 1.7347655458e-05 ! Coefficient of SpV proportional to zs**3 * zp [m3 kg-1] -real, parameter :: SPV401 = -4.3209400767e-06 ! Coefficient of SpV proportional to zs**4 * zp [m3 kg-1] -real, parameter :: SPV011 = 1.5355844621e-05 ! Coefficient of SpV proportional to zt * zp [m3 kg-1] -real, parameter :: SPV111 = 2.0914122241e-06 ! Coefficient of SpV proportional to zs * zt * zp [m3 kg-1] -real, parameter :: SPV211 = -5.7751479725e-06 ! Coefficient of SpV proportional to zs**2 * zt * zp [m3 kg-1] -real, parameter :: SPV311 = 1.0767234341e-06 ! Coefficient of SpV proportional to zs**3 * zt * zp [m3 kg-1] -real, parameter :: SPV021 = -9.6659393016e-06 ! Coefficient of SpV proportional to zt**2 * zp [m3 kg-1] -real, parameter :: SPV121 = -7.0686982208e-07 ! Coefficient of SpV proportional to zs * zt**2 * zp [m3 kg-1] -real, parameter :: SPV221 = 1.4488066593e-06 ! Coefficient of SpV proportional to zs**2 * zt**2 * zp [m3 kg-1] -real, parameter :: SPV031 = 3.1134283336e-06 ! Coefficient of SpV proportional to zt**3 * zp [m3 kg-1] -real, parameter :: SPV131 = 7.9562529879e-08 ! Coefficient of SpV proportional to zs * zt**3 * zp [m3 kg-1] -real, parameter :: SPV041 = -5.6590253863e-07 ! Coefficient of SpV proportional to zt * zp [m3 kg-1] -real, parameter :: SPV002 = 1.0500241168e-06 ! Coefficient of SpV proportional to zp**2 [m3 kg-1] -real, parameter :: SPV102 = 1.9600661704e-06 ! Coefficient of SpV proportional to zs * zp**2 [m3 kg-1] -real, parameter :: SPV202 = -2.1666693382e-06 ! Coefficient of SpV proportional to zs**2 * zp**2 [m3 kg-1] -real, parameter :: SPV012 = -3.8541359685e-06 ! Coefficient of SpV proportional to zt * zp**2 [m3 kg-1] -real, parameter :: SPV112 = 1.0157632247e-06 ! Coefficient of SpV proportional to zs * zt * zp**2 [m3 kg-1] -real, parameter :: SPV022 = 1.7178343158e-06 ! Coefficient of SpV proportional to zt**2 * zp**2 [m3 kg-1] -real, parameter :: SPV003 = -4.1503454190e-07 ! Coefficient of SpV proportional to zp**3 [m3 kg-1] -real, parameter :: SPV103 = 3.5627020989e-07 ! Coefficient of SpV proportional to zs * zp**3 [m3 kg-1] -real, parameter :: SPV013 = -1.1293871415e-07 ! Coefficient of SpV proportional to zt * zp**3 [m3 kg-1] - -real, parameter :: ALP000 = SPV010*r1_T0 ! Constant in the dSpV_dT fit [m3 kg-1 degC-1] -real, parameter :: ALP100 = SPV110*r1_T0 ! Coefficient of the dSpV_dT fit zs term [m3 kg-1 degC-1] -real, parameter :: ALP200 = SPV210*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 term [m3 kg-1 degC-1] -real, parameter :: ALP300 = SPV310*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 term [m3 kg-1 degC-1] -real, parameter :: ALP400 = SPV410*r1_T0 ! Coefficient of the dSpV_dT fit zs**4 term [m3 kg-1 degC-1] -real, parameter :: ALP500 = SPV510*r1_T0 ! Coefficient of the dSpV_dT fit zs**5 term [m3 kg-1 degC-1] -real, parameter :: ALP010 = 2.*SPV020*r1_T0 ! Coefficient of the dSpV_dT fit zt term [m3 kg-1 degC-1] -real, parameter :: ALP110 = 2.*SPV120*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt term [m3 kg-1 degC-1] -real, parameter :: ALP210 = 2.*SPV220*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt term [m3 kg-1 degC-1] -real, parameter :: ALP310 = 2.*SPV320*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 * zt term [m3 kg-1 degC-1] -real, parameter :: ALP410 = 2.*SPV420*r1_T0 ! Coefficient of the dSpV_dT fit zs**4 * zt term [m3 kg-1 degC-1] -real, parameter :: ALP020 = 3.*SPV030*r1_T0 ! Coefficient of the dSpV_dT fit zt**2 term [m3 kg-1 degC-1] -real, parameter :: ALP120 = 3.*SPV130*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt**2 term [m3 kg-1 degC-1] -real, parameter :: ALP220 = 3.*SPV230*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt**2 term [m3 kg-1 degC-1] -real, parameter :: ALP320 = 3.*SPV330*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 * zt**2 term [m3 kg-1 degC-1] -real, parameter :: ALP030 = 4.*SPV040*r1_T0 ! Coefficient of the dSpV_dT fit zt**3 term [m3 kg-1 degC-1] -real, parameter :: ALP130 = 4.*SPV140*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt**3 term [m3 kg-1 degC-1] -real, parameter :: ALP230 = 4.*SPV240*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt**3 term [m3 kg-1 degC-1] -real, parameter :: ALP040 = 5.*SPV050*r1_T0 ! Coefficient of the dSpV_dT fit zt**4 term [m3 kg-1 degC-1] -real, parameter :: ALP140 = 5.*SPV150*r1_T0 ! Coefficient of the dSpV_dT fit zs* * zt**4 term [m3 kg-1 degC-1] -real, parameter :: ALP050 = 6.*SPV060*r1_T0 ! Coefficient of the dSpV_dT fit zt**5 term [m3 kg-1 degC-1] -real, parameter :: ALP001 = SPV011*r1_T0 ! Coefficient of the dSpV_dT fit zp term [m3 kg-1 degC-1] -real, parameter :: ALP101 = SPV111*r1_T0 ! Coefficient of the dSpV_dT fit zs * zp term [m3 kg-1 degC-1] -real, parameter :: ALP201 = SPV211*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zp term [m3 kg-1 degC-1] -real, parameter :: ALP301 = SPV311*r1_T0 ! Coefficient of the dSpV_dT fit zs**3 * zp term [m3 kg-1 degC-1] -real, parameter :: ALP011 = 2.*SPV021*r1_T0 ! Coefficient of the dSpV_dT fit zt * zp term [m3 kg-1 degC-1] -real, parameter :: ALP111 = 2.*SPV121*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt * zp term [m3 kg-1 degC-1] -real, parameter :: ALP211 = 2.*SPV221*r1_T0 ! Coefficient of the dSpV_dT fit zs**2 * zt * zp term [m3 kg-1 degC-1] -real, parameter :: ALP021 = 3.*SPV031*r1_T0 ! Coefficient of the dSpV_dT fit zt**2 * zp term [m3 kg-1 degC-1] -real, parameter :: ALP121 = 3.*SPV131*r1_T0 ! Coefficient of the dSpV_dT fit zs * zt**2 * zp term [m3 kg-1 degC-1] -real, parameter :: ALP031 = 4.*SPV041*r1_T0 ! Coefficient of the dSpV_dT fit zt**3 * zp term [m3 kg-1 degC-1] -real, parameter :: ALP002 = SPV012*r1_T0 ! Coefficient of the dSpV_dT fit zp**2 term [m3 kg-1 degC-1] -real, parameter :: ALP102 = SPV112*r1_T0 ! Coefficient of the dSpV_dT fit zs * zp**2 term [m3 kg-1 degC-1] -real, parameter :: ALP012 = 2.*SPV022*r1_T0 ! Coefficient of the dSpV_dT fit zt * zp**2 term [m3 kg-1 degC-1] -real, parameter :: ALP003 = SPV013*r1_T0 ! Coefficient of the dSpV_dT fit zp**3 term [m3 kg-1 degC-1] - -real, parameter :: BET000 = 0.5*SPV100*r1_S0 ! Constant in the dSpV_dS fit [m3 kg-1 ppt-1] -real, parameter :: BET100 = SPV200*r1_S0 ! Coefficient of the dSpV_dS fit zs term [m3 kg-1 ppt-1] -real, parameter :: BET200 = 1.5*SPV300*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 term [m3 kg-1 ppt-1] -real, parameter :: BET300 = 2.0*SPV400*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 term [m3 kg-1 ppt-1] -real, parameter :: BET400 = 2.5*SPV500*r1_S0 ! Coefficient of the dSpV_dS fit zs**4 term [m3 kg-1 ppt-1] -real, parameter :: BET500 = 3.0*SPV600*r1_S0 ! Coefficient of the dSpV_dS fit zs**5 term [m3 kg-1 ppt-1] -real, parameter :: BET010 = 0.5*SPV110*r1_S0 ! Coefficient of the dSpV_dS fit zt term [m3 kg-1 ppt-1] -real, parameter :: BET110 = SPV210*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt term [m3 kg-1 ppt-1] -real, parameter :: BET210 = 1.5*SPV310*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt term [m3 kg-1 ppt-1] -real, parameter :: BET310 = 2.0*SPV410*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 * zt term [m3 kg-1 ppt-1] -real, parameter :: BET410 = 2.5*SPV510*r1_S0 ! Coefficient of the dSpV_dS fit zs**4 * zt term [m3 kg-1 ppt-1] -real, parameter :: BET020 = 0.5*SPV120*r1_S0 ! Coefficient of the dSpV_dS fit zt**2 term [m3 kg-1 ppt-1] -real, parameter :: BET120 = SPV220*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**2 term [m3 kg-1 ppt-1] -real, parameter :: BET220 = 1.5*SPV320*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt**2 term [m3 kg-1 ppt-1] -real, parameter :: BET320 = 2.0*SPV420*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 * zt**2 term [m3 kg-1 ppt-1] -real, parameter :: BET030 = 0.5*SPV130*r1_S0 ! Coefficient of the dSpV_dS fit zt**3 term [m3 kg-1 ppt-1] -real, parameter :: BET130 = SPV230*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**3 term [m3 kg-1 ppt-1] -real, parameter :: BET230 = 1.5*SPV330*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt**3 term [m3 kg-1 ppt-1] -real, parameter :: BET040 = 0.5*SPV140*r1_S0 ! Coefficient of the dSpV_dS fit zt**4 term [m3 kg-1 ppt-1] -real, parameter :: BET140 = SPV240*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**4 term [m3 kg-1 ppt-1] -real, parameter :: BET050 = 0.5*SPV150*r1_S0 ! Coefficient of the dSpV_dS fit zt**5 term [m3 kg-1 ppt-1] -real, parameter :: BET001 = 0.5*SPV101*r1_S0 ! Coefficient of the dSpV_dS fit zp term [m3 kg-1 ppt-1] -real, parameter :: BET101 = SPV201*r1_S0 ! Coefficient of the dSpV_dS fit zs * zp term [m3 kg-1 ppt-1] -real, parameter :: BET201 = 1.5*SPV301*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zp term [m3 kg-1 ppt-1] -real, parameter :: BET301 = 2.0*SPV401*r1_S0 ! Coefficient of the dSpV_dS fit zs**3 * zp term [m3 kg-1 ppt-1] -real, parameter :: BET011 = 0.5*SPV111*r1_S0 ! Coefficient of the dSpV_dS fit zt * zp term [m3 kg-1 ppt-1] -real, parameter :: BET111 = SPV211*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt * zp term [m3 kg-1 ppt-1] -real, parameter :: BET211 = 1.5*SPV311*r1_S0 ! Coefficient of the dSpV_dS fit zs**2 * zt * zp term [m3 kg-1 ppt-1] -real, parameter :: BET021 = 0.5*SPV121*r1_S0 ! Coefficient of the dSpV_dS fit zt**2 * zp term [m3 kg-1 ppt-1] -real, parameter :: BET121 = SPV221*r1_S0 ! Coefficient of the dSpV_dS fit zs * zt**2 * zp term [m3 kg-1 ppt-1] -real, parameter :: BET031 = 0.5*SPV131*r1_S0 ! Coefficient of the dSpV_dS fit zt**3 * zp term [m3 kg-1 ppt-1] -real, parameter :: BET002 = 0.5*SPV102*r1_S0 ! Coefficient of the dSpV_dS fit zp**2 term [m3 kg-1 ppt-1] -real, parameter :: BET102 = SPV202*r1_S0 ! Coefficient of the dSpV_dS fit zs * zp**2 term [m3 kg-1 ppt-1] -real, parameter :: BET012 = 0.5*SPV112*r1_S0 ! Coefficient of the dSpV_dS fit zt * zp**2 term [m3 kg-1 ppt-1] -real, parameter :: BET003 = 0.5*SPV103*r1_S0 ! Coefficient of the dSpV_dS fit zp**3 term [m3 kg-1 ppt-1] +real, parameter :: rdeltaS = 24. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] +! The following are the coefficients of the fit to the reference density profile (rho00p) as a function of +! pressure (P), with a contribution R0c * P**(c+1). The nomenclature follows Roquet. +real, parameter :: V00 = -4.4015007269e-05*Pa2kb ! SpV00p P coef. [m3 kg-1 Pa-1] +real, parameter :: V01 = 6.9232335784e-06*Pa2kb**2 ! SpV00p P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: V02 = -7.5004675975e-07*Pa2kb**3 ! SpV00p P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: V03 = 1.7009109288e-08*Pa2kb**4 ! SpV00p P**4 coef. [m3 kg-1 Pa-4] +real, parameter :: V04 = -1.6884162004e-08*Pa2kb**5 ! SpV00p P**5 coef. [m3 kg-1 Pa-5] +real, parameter :: V05 = 1.9613503930e-09*Pa2kb**6 ! SpV00p P**6 coef. [m3 kg-1 Pa-6] + +! The following terms are contributions to specific volume (SpV) as a function of the square root of +! normalized absolute salinity with an offset (zs), temperature (T) and pressure (P), with a contribution +! SPVabc * zs**a * T**b * P**c. The numbers here are copied directly from Roquet et al. (2015), but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. +real, parameter :: SPV000 = 1.0772899069e-03 ! Constant SpV contribution [m3 kg-1] +real, parameter :: SPV100 = -3.1263658781e-04 ! SpV zs coef. [m3 kg-1] +real, parameter :: SPV200 = 6.7615860683e-04 ! SpV zs**2 coef. [m3 kg-1] +real, parameter :: SPV300 = -8.6127884515e-04 ! SpV zs**3 coef. [m3 kg-1] +real, parameter :: SPV400 = 5.9010812596e-04 ! SpV zs**4 coef. [m3 kg-1] +real, parameter :: SPV500 = -2.1503943538e-04 ! SpV zs**5 coef. [m3 kg-1] +real, parameter :: SPV600 = 3.2678954455e-05 ! SpV zs**6 coef. [m3 kg-1] +real, parameter :: SPV010 = -1.4949652640e-05*I_Ts ! SpV T coef. [m3 kg-1 degC-1] +real, parameter :: SPV110 = 3.1866349188e-05*I_Ts ! SpV zs * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV210 = -3.8070687610e-05*I_Ts ! SpV zs**2 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV310 = 2.9818473563e-05*I_Ts ! SpV zs**3 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV410 = -1.0011321965e-05*I_Ts ! SpV zs**4 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV510 = 1.0751931163e-06*I_Ts ! SpV zs**5 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV020 = 2.7546851539e-05*I_Ts**2 ! SpV T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV120 = -3.6597334199e-05*I_Ts**2 ! SpV zs * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV220 = 3.4489154625e-05*I_Ts**2 ! SpV zs**2 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV320 = -1.7663254122e-05*I_Ts**2 ! SpV zs**3 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV420 = 3.5965131935e-06*I_Ts**2 ! SpV zs**4 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV030 = -1.6506828994e-05*I_Ts**3 ! SpV T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV130 = 2.4412359055e-05*I_Ts**3 ! SpV zs * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV230 = -1.4606740723e-05*I_Ts**3 ! SpV zs**2 * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV330 = 2.3293406656e-06*I_Ts**3 ! SpV zs**3 * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV040 = 6.7896174634e-06*I_Ts**4 ! SpV T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV140 = -8.7951832993e-06*I_Ts**4 ! SpV zs * T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV240 = 4.4249040774e-06*I_Ts**4 ! SpV zs**2 * T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV050 = -7.2535743349e-07*I_Ts**5 ! SpV T**5 coef. [m3 kg-1 degC-5] +real, parameter :: SPV150 = -3.4680559205e-07*I_Ts**5 ! SpV zs * T**5 coef. [m3 kg-1 degC-5] +real, parameter :: SPV060 = 1.9041365570e-07*I_Ts**6 ! SpV T**6 coef. [m3 kg-1 degC-6] +real, parameter :: SPV001 = -1.6889436589e-05*Pa2kb ! SpV P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV101 = 2.1106556158e-05*Pa2kb ! SpV zs * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV201 = -2.1322804368e-05*Pa2kb ! SpV zs**2 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV301 = 1.7347655458e-05*Pa2kb ! SpV zs**3 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV401 = -4.3209400767e-06*Pa2kb ! SpV zs**4 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV011 = 1.5355844621e-05*(I_Ts*Pa2kb) ! SpV T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV111 = 2.0914122241e-06*(I_Ts*Pa2kb) ! SpV zs * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV211 = -5.7751479725e-06*(I_Ts*Pa2kb) ! SpV zs**2 * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV311 = 1.0767234341e-06*(I_Ts*Pa2kb) ! SpV zs**3 * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV021 = -9.6659393016e-06*(I_Ts**2*Pa2kb) ! SpV T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV121 = -7.0686982208e-07*(I_Ts**2*Pa2kb) ! SpV zs * T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV221 = 1.4488066593e-06*(I_Ts**2*Pa2kb) ! SpV zs**2 * T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV031 = 3.1134283336e-06*(I_Ts**3*Pa2kb) ! SpV T**3 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: SPV131 = 7.9562529879e-08*(I_Ts**3*Pa2kb) ! SpV zs * T**3 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: SPV041 = -5.6590253863e-07*(I_Ts**4*Pa2kb) ! SpV T**4 * P coef. [m3 kg-1 degC-4 Pa-1] +real, parameter :: SPV002 = 1.0500241168e-06*Pa2kb**2 ! SpV P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV102 = 1.9600661704e-06*Pa2kb**2 ! SpV zs * P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV202 = -2.1666693382e-06*Pa2kb**2 ! SpV zs**2 * P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV012 = -3.8541359685e-06*(I_Ts*Pa2kb**2) ! SpV T * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: SPV112 = 1.0157632247e-06*(I_Ts*Pa2kb**2) ! SpV zs * T * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: SPV022 = 1.7178343158e-06*(I_Ts**2*Pa2kb**2) ! SpV T**2 * P**2 coef. [m3 kg-1 degC-2 Pa-2] +real, parameter :: SPV003 = -4.1503454190e-07*Pa2kb**3 ! SpV P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: SPV103 = 3.5627020989e-07*Pa2kb**3 ! SpV zs * P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: SPV013 = -1.1293871415e-07*(I_Ts*Pa2kb**3) ! SpV T * P**3 coef. [m3 kg-1 degC-1 Pa-3] + +real, parameter :: ALP000 = SPV010 ! Constant in the dSpV_dT fit [m3 kg-1 degC-1] +real, parameter :: ALP100 = SPV110 ! dSpV_dT fit zs coef. [m3 kg-1 degC-1] +real, parameter :: ALP200 = SPV210 ! dSpV_dT fit zs**2 coef. [m3 kg-1 degC-1] +real, parameter :: ALP300 = SPV310 ! dSpV_dT fit zs**3 coef. [m3 kg-1 degC-1] +real, parameter :: ALP400 = SPV410 ! dSpV_dT fit zs**4 coef. [m3 kg-1 degC-1] +real, parameter :: ALP500 = SPV510 ! dSpV_dT fit zs**5 coef. [m3 kg-1 degC-1] +real, parameter :: ALP010 = 2.*SPV020 ! dSpV_dT fit T coef. [m3 kg-1 degC-2] +real, parameter :: ALP110 = 2.*SPV120 ! dSpV_dT fit zs * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP210 = 2.*SPV220 ! dSpV_dT fit zs**2 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP310 = 2.*SPV320 ! dSpV_dT fit zs**3 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP410 = 2.*SPV420 ! dSpV_dT fit zs**4 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP020 = 3.*SPV030 ! dSpV_dT fit T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP120 = 3.*SPV130 ! dSpV_dT fit zs * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP220 = 3.*SPV230 ! dSpV_dT fit zs**2 * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP320 = 3.*SPV330 ! dSpV_dT fit zs**3 * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP030 = 4.*SPV040 ! dSpV_dT fit T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP130 = 4.*SPV140 ! dSpV_dT fit zs * T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP230 = 4.*SPV240 ! dSpV_dT fit zs**2 * T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP040 = 5.*SPV050 ! dSpV_dT fit T**4 coef. [m3 kg-1 degC-5] +real, parameter :: ALP140 = 5.*SPV150 ! dSpV_dT fit zs* * T**4 coef. [m3 kg-1 degC-5] +real, parameter :: ALP050 = 6.*SPV060 ! dSpV_dT fit T**5 coef. [m3 kg-1 degC-6] +real, parameter :: ALP001 = SPV011 ! dSpV_dT fit P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP101 = SPV111 ! dSpV_dT fit zs * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP201 = SPV211 ! dSpV_dT fit zs**2 * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP301 = SPV311 ! dSpV_dT fit zs**3 * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP011 = 2.*SPV021 ! dSpV_dT fit T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP111 = 2.*SPV121 ! dSpV_dT fit zs * T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP211 = 2.*SPV221 ! dSpV_dT fit zs**2 * T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP021 = 3.*SPV031 ! dSpV_dT fit T**2 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: ALP121 = 3.*SPV131 ! dSpV_dT fit zs * T**2 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: ALP031 = 4.*SPV041 ! dSpV_dT fit T**3 * P coef. [m3 kg-1 degC-4 Pa-1] +real, parameter :: ALP002 = SPV012 ! dSpV_dT fit P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: ALP102 = SPV112 ! dSpV_dT fit zs * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: ALP012 = 2.*SPV022 ! dSpV_dT fit T * P**2 coef. [m3 kg-1 degC-2 Pa-2] +real, parameter :: ALP003 = SPV013 ! dSpV_dT fit P**3 coef. [m3 kg-1 degC-1 Pa-3] + +real, parameter :: BET000 = 0.5*SPV100*r1_S0 ! Constant in the dSpV_dS fit [m3 kg-1 ppt-1] +real, parameter :: BET100 = SPV200*r1_S0 ! dSpV_dS fit zs coef. [m3 kg-1 ppt-1] +real, parameter :: BET200 = 1.5*SPV300*r1_S0 ! dSpV_dS fit zs**2 coef. [m3 kg-1 ppt-1] +real, parameter :: BET300 = 2.0*SPV400*r1_S0 ! dSpV_dS fit zs**3 coef. [m3 kg-1 ppt-1] +real, parameter :: BET400 = 2.5*SPV500*r1_S0 ! dSpV_dS fit zs**4 coef. [m3 kg-1 ppt-1] +real, parameter :: BET500 = 3.0*SPV600*r1_S0 ! dSpV_dS fit zs**5 coef. [m3 kg-1 ppt-1] +real, parameter :: BET010 = 0.5*SPV110*r1_S0 ! dSpV_dS fit T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET110 = SPV210*r1_S0 ! dSpV_dS fit zs * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET210 = 1.5*SPV310*r1_S0 ! dSpV_dS fit zs**2 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET310 = 2.0*SPV410*r1_S0 ! dSpV_dS fit zs**3 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET410 = 2.5*SPV510*r1_S0 ! dSpV_dS fit zs**4 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET020 = 0.5*SPV120*r1_S0 ! dSpV_dS fit T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET120 = SPV220*r1_S0 ! dSpV_dS fit zs * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET220 = 1.5*SPV320*r1_S0 ! dSpV_dS fit zs**2 * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET320 = 2.0*SPV420*r1_S0 ! dSpV_dS fit zs**3 * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET030 = 0.5*SPV130*r1_S0 ! dSpV_dS fit T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET130 = SPV230*r1_S0 ! dSpV_dS fit zs * T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET230 = 1.5*SPV330*r1_S0 ! dSpV_dS fit zs**2 * T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET040 = 0.5*SPV140*r1_S0 ! dSpV_dS fit T**4 coef. [m3 kg-1 ppt-1 degC-4] +real, parameter :: BET140 = SPV240*r1_S0 ! dSpV_dS fit zs * T**4 coef. [m3 kg-1 ppt-1 degC-4] +real, parameter :: BET050 = 0.5*SPV150*r1_S0 ! dSpV_dS fit T**5 coef. [m3 kg-1 ppt-1 degC-5] +real, parameter :: BET001 = 0.5*SPV101*r1_S0 ! dSpV_dS fit P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET101 = SPV201*r1_S0 ! dSpV_dS fit zs * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET201 = 1.5*SPV301*r1_S0 ! dSpV_dS fit zs**2 * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET301 = 2.0*SPV401*r1_S0 ! dSpV_dS fit zs**3 * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET011 = 0.5*SPV111*r1_S0 ! dSpV_dS fit T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET111 = SPV211*r1_S0 ! dSpV_dS fit zs * T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET211 = 1.5*SPV311*r1_S0 ! dSpV_dS fit zs**2 * T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET021 = 0.5*SPV121*r1_S0 ! dSpV_dS fit T**2 * P coef. [m3 kg-1 ppt-1 degC-2 Pa-1] +real, parameter :: BET121 = SPV221*r1_S0 ! dSpV_dS fit zs * T**2 * P coef. [m3 kg-1 ppt-1 degC-2 Pa-1] +real, parameter :: BET031 = 0.5*SPV131*r1_S0 ! dSpV_dS fit T**3 * P coef. [m3 kg-1 ppt-1 degC-3 Pa-1] +real, parameter :: BET002 = 0.5*SPV102*r1_S0 ! dSpV_dS fit P**2 coef. [m3 kg-1 ppt-1 Pa-2] +real, parameter :: BET102 = SPV202*r1_S0 ! dSpV_dS fit zs * P**2 coef. [m3 kg-1 ppt-1 Pa-2] +real, parameter :: BET012 = 0.5*SPV112*r1_S0 ! dSpV_dS fit T * P**2 coef. [m3 kg-1 ppt-1 degC-1 Pa-2] +real, parameter :: BET003 = 0.5*SPV103*r1_S0 ! dSpV_dS fit P**3 coef. [m3 kg-1 ppt-1 Pa-3] !>@} contains @@ -186,7 +189,7 @@ module MOM_EOS_Roquet_Spv !> Computes the Roquet et al. in situ specific volume of sea water for scalar inputs and outputs. !! !! Returns the in situ specific volume of sea water (specvol in [m3 kg-1]) from absolute salinity (S [g kg-1]), -!! conservative temperature (T [degC]) and pressure [Pa]. It uses the specific volume polynomial +!! conservative temperature (T [degC]) and pressure [Pa]. It uses the specific volume polynomial !! fit from Roquet et al. (2015). !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_Roquet_SpV(T, S, pressure, specvol, spv_ref) @@ -199,12 +202,12 @@ subroutine calculate_spec_vol_scalar_Roquet_SpV(T, S, pressure, specvol, spv_ref ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the absolutes salinity [g kg-1] - real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: pres0 ! A 1-d array with a copy of the pressure [Pa] real, dimension(1) :: spv0 ! A 1-d array with a copy of the specific volume [m3 kg-1] - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + T0(1) = T ; S0(1) = S ; pres0(1) = pressure - call calculate_spec_vol_array_Roquet_SpV(T0, S0, pressure0, spv0, 1, 1, spv_ref) + call calculate_spec_vol_array_Roquet_SpV(T0, S0, pres0, spv0, 1, 1, spv_ref) specvol = spv0(1) end subroutine calculate_spec_vol_scalar_Roquet_SpV @@ -225,34 +228,34 @@ subroutine calculate_spec_vol_array_Roquet_SpV(T, S, pressure, specvol, start, n real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] ! Local variables - real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] - real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized - ! by an assumed salinity range [nondim] + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to ! specific volume at the reference temperature and salinity [m3 kg-1] real :: SV_TS ! Specific volume without a pressure-dependent contribution [m3 kg-1] real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at ! the surface pressure [m3 kg-1] real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is - ! proportional to pressure [m3 kg-1] + ! proportional to pressure [m3 kg-1 Pa-1] real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is - ! proportional to pressure**2 [m3 kg-1] + ! proportional to pressure**2 [m3 kg-1 Pa-2] real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is - ! proportional to pressure**3 [m3 kg-1] + ! proportional to pressure**3 [m3 kg-1 Pa-3] real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] integer :: j ! The following algorithm was published by Roquet et al. (2015), intended for use in non-Boussinesq ocean models. do j=start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = pressure(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) @@ -261,7 +264,7 @@ subroutine calculate_spec_vol_array_Roquet_SpV(T, S, pressure, specvol, start, n SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & - + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) SV_TS0 = zt*(SPV010 & + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & @@ -294,18 +297,18 @@ subroutine calculate_density_scalar_Roquet_SpV(T, S, pressure, rho, rho_ref) real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] - real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: pres0 ! A 1-d array with a copy of the pressure [Pa] real, dimension(1) :: spv ! A 1-d array with the specific volume [m3 kg-1] T0(1) = T S0(1) = S - pressure0(1) = pressure + pres0(1) = pressure if (present(rho_ref)) then - call calculate_spec_vol_array_Roquet_SpV(T0, S0, pressure0, spv, 1, 1, spv_ref=1.0/rho_ref) + call calculate_spec_vol_array_Roquet_SpV(T0, S0, pres0, spv, 1, 1, spv_ref=1.0/rho_ref) rho = -rho_ref**2*spv(1) / (rho_ref*spv(1) + 1.0) ! In situ density [kg m-3] else - call calculate_spec_vol_array_Roquet_SpV(T0, S0, pressure0, spv, 1, 1) + call calculate_spec_vol_array_Roquet_SpV(T0, S0, pres0, spv, 1, 1) rho = 1.0 / spv(1) endif @@ -354,37 +357,37 @@ subroutine calculate_specvol_derivs_Roquet_SpV(T, S, pressure, dSV_dT, dSV_dS, s integer, intent(in) :: start !< The starting index for calculations integer, intent(in) :: npts !< The number of values to calculate - real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] - real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized - ! by an assumed salinity range [nondim] - real :: dSVdzt0 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] - ! from temperature anomalies at the surface pressure - real :: dSVdzt1 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] - ! that is proportional to pressure - real :: dSVdzt2 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] - ! that is proportional to pressure^2 - real :: dSVdzt3 ! A contribution to the partial derivative of specific volume with temperature [m3 kg-1 degC-1] - ! that is proportional to pressure^3 + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dSVdzt0 ! A contribution to the partial derivative of specific volume with temperature + ! from temperature anomalies at the surface pressure [m3 kg-1 degC-1] + real :: dSVdzt1 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure [m3 kg-1 degC-1 Pa-1] + real :: dSVdzt2 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure**2 [m3 kg-1 degC-1 Pa-2] + real :: dSVdzt3 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure**3 [m3 kg-1 degC-1 Pa-3] real :: dSVdzs0 ! A contribution to the partial derivative of specific volume with ! salinity [m3 kg-1 ppt-1] from temperature anomalies at the surface pressure real :: dSVdzs1 ! A contribution to the partial derivative of specific volume with - ! salinity [m3 kg-1 ppt-1] proportional to pressure + ! salinity [m3 kg-1 ppt-1 Pa-1] proportional to pressure real :: dSVdzs2 ! A contribution to the partial derivative of specific volume with - ! salinity [m3 kg-1 ppt-1] proportional to pressure^2 + ! salinity [m3 kg-1 ppt-1 Pa-2] proportional to pressure**2 real :: dSVdzs3 ! A contribution to the partial derivative of specific volume with - ! salinity [m3 kg-1 ppt-1] proportional to pressure^3 + ! salinity [m3 kg-1 ppt-1 Pa-3] proportional to pressure**3 integer :: j do j=start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = pressure(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. ! Find the partial derivative of specific volume with temperature @@ -466,7 +469,7 @@ subroutine calculate_density_derivs_scalar_Roquet_SpV(T, S, pressure, drho_dt, d ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] - real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: pres0 ! A 1-d array with a copy of the pressure [Pa] real, dimension(1) :: drdt0 ! A 1-d array with a copy of the derivative of density ! with conservative temperature [kg m-3 degC-1] real, dimension(1) :: drds0 ! A 1-d array with a copy of the derivative of density @@ -474,9 +477,9 @@ subroutine calculate_density_derivs_scalar_Roquet_SpV(T, S, pressure, drho_dt, d T0(1) = T S0(1) = S - pressure0(1) = pressure + pres0(1) = pressure - call calculate_density_derivs_array_Roquet_SpV(T0, S0, pressure0, drdt0, drds0, 1, 1) + call calculate_density_derivs_array_Roquet_SpV(T0, S0, pres0, drdt0, drds0, 1, 1) drho_dt = drdt0(1) drho_ds = drds0(1) end subroutine calculate_density_derivs_scalar_Roquet_SpV @@ -494,28 +497,28 @@ subroutine calculate_compress_Roquet_SpV(T, S, pressure, rho, drho_dp, start, np !! (also the inverse of the square of sound speed) !! [s2 m-2] integer, intent(in) :: start !< The starting index for calculations - integer, intent(in) :: npts !< The number of values to calculate. + integer, intent(in) :: npts !< The number of values to calculate ! Local variables - real :: zp ! Pressure normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] - real :: zs ! The square root of absolute salinity with an offset normalized - ! by an assumed salinity range [nondim] + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] real :: dSV_00p_dp ! Derivative of the pressure-dependent reference specific volume profile with - ! normalized pressure [m3 kg-1] + ! pressure [m3 kg-1 Pa-1] real :: dSV_TS_dp ! Derivative of the specific volume anomaly from the reference profile with - ! normalized pressure [m3 kg-1] + ! pressure [m3 kg-1 Pa-1] real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to ! specific volume at the reference temperature and salinity [m3 kg-1] real :: SV_TS ! specific volume without a pressure-dependent contribution [m3 kg-1] real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at ! the surface pressure [m3 kg-1] real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is - ! proportional to pressure [m3 kg-1] + ! proportional to pressure [m3 kg-1 Pa-1] real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is - ! proportional to pressure**2 [m3 kg-1] + ! proportional to pressure**2 [m3 kg-1 Pa-2] real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is - ! proportional to pressure**3 [m3 kg-1] + ! proportional to pressure**3 [m3 kg-1 Pa-3] real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] real :: dSpecVol_dp ! The partial derivative of specific volume with pressure [m3 kg-1 Pa-1] integer :: j @@ -524,13 +527,13 @@ subroutine calculate_compress_Roquet_SpV(T, S, pressure, rho, drho_dp, start, np ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. do j=start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = pressure(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) @@ -539,7 +542,7 @@ subroutine calculate_compress_Roquet_SpV(T, S, pressure, rho, drho_dp, start, np SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & - + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) SV_TS0 = zt*(SPV010 & + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & @@ -558,7 +561,7 @@ subroutine calculate_compress_Roquet_SpV(T, S, pressure, rho, drho_dp, start, np dSV_00p_dp = V00 + zp*(2.*V01 + zp*(3.*V02 + zp*(4.*V03 + zp*(5.*V04 + zp*(6.*V05))))) dSV_TS_dp = SV_TS1 + zp*(2.*SV_TS2 + zp*(3.*SV_TS3)) - dSpecVol_dp = (dSV_TS_dp + dSV_00p_dp) * (Pa2db*r1_P0) ! [m3 kg-1 Pa-1] + dSpecVol_dp = dSV_TS_dp + dSV_00p_dp ! [m3 kg-1 Pa-1] drho_dp(j) = -dSpecVol_dp * rho(j)**2 ! Compressibility [s2 m-2] enddo @@ -582,30 +585,30 @@ subroutine calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ !! and salinity [m3 kg-1 ppt-1 Pa-1] real, dimension(:), intent(inout) :: dSV_dt_dp !< Second derivative of specific volume with respect to pressure !! and temperature [m3 kg-1 degC-1 Pa-1] - integer, intent(in ) :: start !< Starting index in T,S,P - integer, intent(in ) :: npts !< Number of points to loop over + integer, intent(in ) :: start !< The starting index for calculations + integer, intent(in ) :: npts !< The number of values to calculate ! Local variables - real :: zp ! Pressure normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] - real :: zs ! The square root of absolute salinity with an offset normalized - ! by an assumed salinity range [nondim] - real :: I_s ! The inverse of zs [nondim] + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: I_s ! The inverse of zs [nondim] real :: d2SV_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] real :: d2SV_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] - real :: d2SV_p2 ! A contribution to one of the second derivatives that is proportional to pressure^2 [various] - real :: d2SV_p3 ! A contribution to one of the second derivatives that is proportional to pressure^3 [various] + real :: d2SV_p2 ! A contribution to one of the second derivatives that is proportional to pressure**2 [various] + real :: d2SV_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] integer :: j do j = start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = P(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = P(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. I_s = 1.0 / zs @@ -630,7 +633,7 @@ subroutine calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ + zt*(3.*SPV130 + (zs*(6.*SPV230 + zs*(9.*SPV330)) & + zt*(4.*SPV140 + (zs*(8.*SPV240) & + zt*(5.*SPV150))) )) )) ) - dSV_ds_dt(j) = (0.5*r1_S0*r1_T0) * ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) + dSV_ds_dt(j) = (0.5*r1_S0) * ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) ! Find dSV_dt_dt d2SV_p2 = 2.*SPV022 @@ -641,7 +644,7 @@ subroutine calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ + zt*(12.*SPV040 + (zs*(12.*SPV140 + zs *(12.*SPV240)) & + zt*(20.*SPV050 + (zs*(20.*SPV150) & + zt*(30.*SPV060) )) )) )) ) - dSV_dt_dt(j) = (d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * r1_T0**2 + dSV_dt_dt(j) = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) ! Find dSV_ds_dp d2SV_p2 = 3.*SPV103 @@ -649,7 +652,7 @@ subroutine calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ d2SV_p0 = SPV101 + (zs*(2.*SPV201 + zs*(3.*SPV301 + zs*(4.*SPV401))) & + zt*(SPV111 + (zs*(2.*SPV211 + zs*(3.*SPV311)) & + zt*( SPV121 + (zs*(2.*SPV221) + zt*SPV131)) )) ) - dSV_ds_dp(j) = ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) * (0.5*r1_S0 * Pa2db*r1_P0) + dSV_ds_dp(j) = ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) * (0.5*r1_S0) ! Find dSV_dt_dp d2SV_p2 = 3.*SPV013 @@ -657,7 +660,7 @@ subroutine calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ d2SV_p0 = SPV011 + (zs*(SPV111 + zs*( SPV211 + zs* SPV311)) & + zt*(2.*SPV021 + (zs*(2.*SPV121 + zs*(2.*SPV221)) & + zt*(3.*SPV031 + (zs*(3.*SPV131) + zt*(4.*SPV041))) )) ) - dSV_dt_dp(j) = (d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * (Pa2db*r1_P0* r1_T0) + dSV_dt_dp(j) = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) enddo end subroutine calc_spec_vol_second_derivs_array_Roquet_SpV @@ -680,8 +683,8 @@ subroutine calculate_density_second_derivs_array_Roquet_SpV(T, S, P, drho_ds_ds, !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] real, dimension(:), intent(inout) :: drho_dt_dp !< Second derivative of density with respect to pressure !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] - integer, intent(in ) :: start !< Starting index in T,S,P - integer, intent(in ) :: npts !< Number of points to loop over + integer, intent(in ) :: start !< The starting index for calculations + integer, intent(in ) :: npts !< The number of values to calculate ! Local variables real, dimension(size(T)) :: rho ! The in situ density [kg m-3] @@ -747,9 +750,9 @@ subroutine calculate_density_second_derivs_scalar_Roquet_SpV(T, S, P, drho_ds_ds real, intent( out) :: drho_dt_dp !< Second derivative of density with respect to pressure !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] ! Local variables - real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] - real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [g kg-1] - real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [g kg-1] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 ppt-2] real, dimension(1) :: drdsdt ! The second derivative of density with salinity and ! temperature [kg m-3 ppt-1 degC-1] diff --git a/src/equation_of_state/MOM_EOS_Roquet_rho.F90 b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 index 75276ac25b..6d7a7a143e 100644 --- a/src/equation_of_state/MOM_EOS_Roquet_rho.F90 +++ b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 @@ -28,148 +28,153 @@ module MOM_EOS_Roquet_rho !> Compute the second derivatives of density with various combinations of temperature, !! salinity, and pressure using the expressions for density from Roquet et al. (2015) interface calculate_density_second_derivs_Roquet_rho - module procedure calculate_density_second_derivs_scalar_Roquet_rho, calculate_density_second_derivs_array_Roquet_rho + module procedure calculate_density_second_derivs_scalar_Roquet_rho + module procedure calculate_density_second_derivs_array_Roquet_rho end interface calculate_density_second_derivs_Roquet_rho -real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar [dbar Pa-1] +real, parameter :: Pa2kb = 1.e-8 !< Conversion factor between Pa and kbar [kbar Pa-1] !>@{ Parameters in the Roquet_rho (Roquet density) equation of state -real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] -real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] -real, parameter :: r1_T0 = 1./40. ! The inverse of a plausible range of oceanic temperatures [degC-1] -real, parameter :: r1_P0 = 1.e-4 ! The inverse of a plausible range of oceanic pressures [dbar-1] -real, parameter :: R00 = 4.6494977072e+01 ! Contribution to rho00p proportional to zp [kg m-3] -real, parameter :: R01 = -5.2099962525 ! Contribution to rho00p proportional to zp**2 [kg m-3] -real, parameter :: R02 = 2.2601900708e-01 ! Contribution to rho00p proportional to zp**3 [kg m-3] -real, parameter :: R03 = 6.4326772569e-02 ! Contribution to rho00p proportional to zp**4 [kg m-3] -real, parameter :: R04 = 1.5616995503e-02 ! Contribution to rho00p proportional to zp**5 [kg m-3] -real, parameter :: R05 = -1.7243708991e-03 ! Contribution to rho00p proportional to zp**6 [kg m-3] - -! The following terms are contributions to density as a function of the normalized square root of salinity -! with an offset (zs), temperature (zt) and pressure (zp), with a contribution EOSabc * zs**a * zt**b * zp**c -real, parameter :: EOS000 = 8.0189615746e+02 ! A constant density contribution [kg m-3] -real, parameter :: EOS100 = 8.6672408165e+02 ! Coefficient of the EOS proportional to zs [kg m-3] -real, parameter :: EOS200 = -1.7864682637e+03 ! Coefficient of the EOS proportional to zs**2 [kg m-3] -real, parameter :: EOS300 = 2.0375295546e+03 ! Coefficient of the EOS proportional to zs**3 [kg m-3] -real, parameter :: EOS400 = -1.2849161071e+03 ! Coefficient of the EOS proportional to zs**4 [kg m-3] -real, parameter :: EOS500 = 4.3227585684e+02 ! Coefficient of the EOS proportional to zs**5 [kg m-3] -real, parameter :: EOS600 = -6.0579916612e+01 ! Coefficient of the EOS proportional to zs**6 [kg m-3] -real, parameter :: EOS010 = 2.6010145068e+01 ! Coefficient of the EOS proportional to zt [kg m-3] -real, parameter :: EOS110 = -6.5281885265e+01 ! Coefficient of the EOS proportional to zs * zt [kg m-3] -real, parameter :: EOS210 = 8.1770425108e+01 ! Coefficient of the EOS proportional to zs**2 * zt [kg m-3] -real, parameter :: EOS310 = -5.6888046321e+01 ! Coefficient of the EOS proportional to zs**3 * zt [kg m-3] -real, parameter :: EOS410 = 1.7681814114e+01 ! Coefficient of the EOS proportional to zs**2 * zt [kg m-3] -real, parameter :: EOS510 = -1.9193502195 ! Coefficient of the EOS proportional to zs**5 * zt [kg m-3] -real, parameter :: EOS020 = -3.7074170417e+01 ! Coefficient of the EOS proportional to zt**2 [kg m-3] -real, parameter :: EOS120 = 6.1548258127e+01 ! Coefficient of the EOS proportional to zs * zt**2 [kg m-3] -real, parameter :: EOS220 = -6.0362551501e+01 ! Coefficient of the EOS proportional to zs**2 * zt**2 [kg m-3] -real, parameter :: EOS320 = 2.9130021253e+01 ! Coefficient of the EOS proportional to s**3 * zt**2 [kg m-3] -real, parameter :: EOS420 = -5.4723692739 ! Coefficient of the EOS proportional to zs**4 * zt**2 [kg m-3] -real, parameter :: EOS030 = 2.1661789529e+01 ! Coefficient of the EOS proportional to zt**3 [kg m-3] -real, parameter :: EOS130 = -3.3449108469e+01 ! Coefficient of the EOS proportional to zs * zt**3 [kg m-3] -real, parameter :: EOS230 = 1.9717078466e+01 ! Coefficient of the EOS proportional to zs**2 * zt**3 [kg m-3] -real, parameter :: EOS330 = -3.1742946532 ! Coefficient of the EOS proportional to zs**3 * zt**3 [kg m-3] -real, parameter :: EOS040 = -8.3627885467 ! Coefficient of the EOS proportional to zt**4 [kg m-3] -real, parameter :: EOS140 = 1.1311538584e+01 ! Coefficient of the EOS proportional to zs * zt**4 [kg m-3] -real, parameter :: EOS240 = -5.3563304045 ! Coefficient of the EOS proportional to zs**2 * zt**4 [kg m-3] -real, parameter :: EOS050 = 5.4048723791e-01 ! Coefficient of the EOS proportional to zt**5 [kg m-3] -real, parameter :: EOS150 = 4.8169980163e-01 ! Coefficient of the EOS proportional to zs * zt**5 [kg m-3] -real, parameter :: EOS060 = -1.9083568888e-01 ! Coefficient of the EOS proportional to zt**6 [kg m-3] -real, parameter :: EOS001 = 1.9681925209e+01 ! Coefficient of the EOS proportional to zp [kg m-3] -real, parameter :: EOS101 = -4.2549998214e+01 ! Coefficient of the EOS proportional to zs * zp [kg m-3] -real, parameter :: EOS201 = 5.0774768218e+01 ! Coefficient of the EOS proportional to zs**2 * zp [kg m-3] -real, parameter :: EOS301 = -3.0938076334e+01 ! Coefficient of the EOS proportional to zs**3 * zp [kg m-3] -real, parameter :: EOS401 = 6.6051753097 ! Coefficient of the EOS proportional to zs**4 * zp [kg m-3] -real, parameter :: EOS011 = -1.3336301113e+01 ! Coefficient of the EOS proportional to zt * zp [kg m-3] -real, parameter :: EOS111 = -4.4870114575 ! Coefficient of the EOS proportional to zs * zt * zp [kg m-3] -real, parameter :: EOS211 = 5.0042598061 ! Coefficient of the EOS proportional to zs**2 * zt * zp [kg m-3] -real, parameter :: EOS311 = -6.5399043664e-01 ! Coefficient of the EOS proportional to zs**3 * zt * zp [kg m-3] -real, parameter :: EOS021 = 6.7080479603 ! Coefficient of the EOS proportional to zt**2 * zp [kg m-3] -real, parameter :: EOS121 = 3.5063081279 ! Coefficient of the EOS proportional to zs * zt**2 * zp [kg m-3] -real, parameter :: EOS221 = -1.8795372996 ! Coefficient of the EOS proportional to zs**2 * zt**2 * zp [kg m-3] -real, parameter :: EOS031 = -2.4649669534 ! Coefficient of the EOS proportional to zt**3 * zp [kg m-3] -real, parameter :: EOS131 = -5.5077101279e-01 ! Coefficient of the EOS proportional to zs * zt**3 * zp [kg m-3] -real, parameter :: EOS041 = 5.5927935970e-01 ! Coefficient of the EOS proportional to zt**4 * zp [kg m-3] -real, parameter :: EOS002 = 2.0660924175 ! Coefficient of the EOS proportional to zp**2 [kg m-3] -real, parameter :: EOS102 = -4.9527603989 ! Coefficient of the EOS proportional to zs * zp**2 [kg m-3] -real, parameter :: EOS202 = 2.5019633244 ! Coefficient of the EOS proportional to zs**2 * zp**2 [kg m-3] -real, parameter :: EOS012 = 2.0564311499 ! Coefficient of the EOS proportional to zt * zp**2 [kg m-3] -real, parameter :: EOS112 = -2.1311365518e-01 ! Coefficient of the EOS proportional to zs * zt * zp**2 [kg m-3] -real, parameter :: EOS022 = -1.2419983026 ! Coefficient of the EOS proportional to zt**2 * zp**2 [kg m-3] -real, parameter :: EOS003 = -2.3342758797e-02 ! Coefficient of the EOS proportional to zp**3 [kg m-3] -real, parameter :: EOS103 = -1.8507636718e-02 ! Coefficient of the EOS proportional to zs * zp**3 [kg m-3] -real, parameter :: EOS013 = 3.7969820455e-01 ! Coefficient of the EOS proportional to zt * zp**3 [kg m-3] - -real, parameter :: ALP000 = EOS010*r1_T0 ! Constant in the drho_dT fit [kg m-3 degC-1] -real, parameter :: ALP100 = EOS110*r1_T0 ! Coefficient of the drho_dT fit zs term [kg m-3 degC-1] -real, parameter :: ALP200 = EOS210*r1_T0 ! Coefficient of the drho_dT fit zs**2 term [kg m-3 degC-1] -real, parameter :: ALP300 = EOS310*r1_T0 ! Coefficient of the drho_dT fit zs**3 term [kg m-3 degC-1] -real, parameter :: ALP400 = EOS410*r1_T0 ! Coefficient of the drho_dT fit zs**4 term [kg m-3 degC-1] -real, parameter :: ALP500 = EOS510*r1_T0 ! Coefficient of the drho_dT fit zs**5 term [kg m-3 degC-1] -real, parameter :: ALP010 = 2.*EOS020*r1_T0 ! Coefficient of the drho_dT fit zt term [kg m-3 degC-1] -real, parameter :: ALP110 = 2.*EOS120*r1_T0 ! Coefficient of the drho_dT fit zs * zt term [kg m-3 degC-1] -real, parameter :: ALP210 = 2.*EOS220*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt term [kg m-3 degC-1] -real, parameter :: ALP310 = 2.*EOS320*r1_T0 ! Coefficient of the drho_dT fit zs**3 * zt term [kg m-3 degC-1] -real, parameter :: ALP410 = 2.*EOS420*r1_T0 ! Coefficient of the drho_dT fit zs**4 * zt term [kg m-3 degC-1] -real, parameter :: ALP020 = 3.*EOS030*r1_T0 ! Coefficient of the drho_dT fit zt**2 term [kg m-3 degC-1] -real, parameter :: ALP120 = 3.*EOS130*r1_T0 ! Coefficient of the drho_dT fit zs * zt**2 term [kg m-3 degC-1] -real, parameter :: ALP220 = 3.*EOS230*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt**2 term [kg m-3 degC-1] -real, parameter :: ALP320 = 3.*EOS330*r1_T0 ! Coefficient of the drho_dT fit zs**3 * zt**2 term [kg m-3 degC-1] -real, parameter :: ALP030 = 4.*EOS040*r1_T0 ! Coefficient of the drho_dT fit zt**3 term [kg m-3 degC-1] -real, parameter :: ALP130 = 4.*EOS140*r1_T0 ! Coefficient of the drho_dT fit zs * zt**3 term [kg m-3 degC-1] -real, parameter :: ALP230 = 4.*EOS240*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt**3 term [kg m-3 degC-1] -real, parameter :: ALP040 = 5.*EOS050*r1_T0 ! Coefficient of the drho_dT fit zt**4 term [kg m-3 degC-1] -real, parameter :: ALP140 = 5.*EOS150*r1_T0 ! Coefficient of the drho_dT fit zs* * zt**4 term [kg m-3 degC-1] -real, parameter :: ALP050 = 6.*EOS060*r1_T0 ! Coefficient of the drho_dT fit zt**5 term [kg m-3 degC-1] -real, parameter :: ALP001 = EOS011*r1_T0 ! Coefficient of the drho_dT fit zp term [kg m-3 degC-1] -real, parameter :: ALP101 = EOS111*r1_T0 ! Coefficient of the drho_dT fit zs * zp term [kg m-3 degC-1] -real, parameter :: ALP201 = EOS211*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zp term [kg m-3 degC-1] -real, parameter :: ALP301 = EOS311*r1_T0 ! Coefficient of the drho_dT fit zs**3 * zp term [kg m-3 degC-1] -real, parameter :: ALP011 = 2.*EOS021*r1_T0 ! Coefficient of the drho_dT fit zt * zp term [kg m-3 degC-1] -real, parameter :: ALP111 = 2.*EOS121*r1_T0 ! Coefficient of the drho_dT fit zs * zt * zp term [kg m-3 degC-1] -real, parameter :: ALP211 = 2.*EOS221*r1_T0 ! Coefficient of the drho_dT fit zs**2 * zt * zp term [kg m-3 degC-1] -real, parameter :: ALP021 = 3.*EOS031*r1_T0 ! Coefficient of the drho_dT fit zt**2 * zp term [kg m-3 degC-1] -real, parameter :: ALP121 = 3.*EOS131*r1_T0 ! Coefficient of the drho_dT fit zs * zt**2 * zp term [kg m-3 degC-1] -real, parameter :: ALP031 = 4.*EOS041*r1_T0 ! Coefficient of the drho_dT fit zt**3 * zp term [kg m-3 degC-1] -real, parameter :: ALP002 = EOS012*r1_T0 ! Coefficient of the drho_dT fit zp**2 term [kg m-3 degC-1] -real, parameter :: ALP102 = EOS112*r1_T0 ! Coefficient of the drho_dT fit zs * zp**2 term [kg m-3 degC-1] -real, parameter :: ALP012 = 2.*EOS022*r1_T0 ! Coefficient of the drho_dT fit zt * zp**2 term [kg m-3 degC-1] -real, parameter :: ALP003 = EOS013*r1_T0 ! Coefficient of the drho_dT fit zp**3 term [kg m-3 degC-1] - -real, parameter :: BET000 = 0.5*EOS100*r1_S0 ! Constant in the drho_dS fit [kg m-3 ppt-1] -real, parameter :: BET100 = EOS200*r1_S0 ! Coefficient of the drho_dS fit zs term [kg m-3 ppt-1] -real, parameter :: BET200 = 1.5*EOS300*r1_S0 ! Coefficient of the drho_dS fit zs**2 term [kg m-3 ppt-1] -real, parameter :: BET300 = 2.0*EOS400*r1_S0 ! Coefficient of the drho_dS fit zs**3 term [kg m-3 ppt-1] -real, parameter :: BET400 = 2.5*EOS500*r1_S0 ! Coefficient of the drho_dS fit zs**4 term [kg m-3 ppt-1] -real, parameter :: BET500 = 3.0*EOS600*r1_S0 ! Coefficient of the drho_dS fit zs**5 term [kg m-3 ppt-1] -real, parameter :: BET010 = 0.5*EOS110*r1_S0 ! Coefficient of the drho_dS fit zt term [kg m-3 ppt-1] -real, parameter :: BET110 = EOS210*r1_S0 ! Coefficient of the drho_dS fit zs * zt term [kg m-3 ppt-1] -real, parameter :: BET210 = 1.5*EOS310*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt term [kg m-3 ppt-1] -real, parameter :: BET310 = 2.0*EOS410*r1_S0 ! Coefficient of the drho_dS fit zs**3 * zt term [kg m-3 ppt-1] -real, parameter :: BET410 = 2.5*EOS510*r1_S0 ! Coefficient of the drho_dS fit zs**4 * zt term [kg m-3 ppt-1] -real, parameter :: BET020 = 0.5*EOS120*r1_S0 ! Coefficient of the drho_dS fit zt**2 term [kg m-3 ppt-1] -real, parameter :: BET120 = EOS220*r1_S0 ! Coefficient of the drho_dS fit zs * zt**2 term [kg m-3 ppt-1] -real, parameter :: BET220 = 1.5*EOS320*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt**2 term [kg m-3 ppt-1] -real, parameter :: BET320 = 2.0*EOS420*r1_S0 ! Coefficient of the drho_dS fit zs**3 * zt**2 term [kg m-3 ppt-1] -real, parameter :: BET030 = 0.5*EOS130*r1_S0 ! Coefficient of the drho_dS fit zt**3 term [kg m-3 ppt-1] -real, parameter :: BET130 = EOS230*r1_S0 ! Coefficient of the drho_dS fit zs * zt**3 term [kg m-3 ppt-1] -real, parameter :: BET230 = 1.5*EOS330*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt**3 term [kg m-3 ppt-1] -real, parameter :: BET040 = 0.5*EOS140*r1_S0 ! Coefficient of the drho_dS fit zt**4 term [kg m-3 ppt-1] -real, parameter :: BET140 = EOS240*r1_S0 ! Coefficient of the drho_dS fit zs * zt**4 term [kg m-3 ppt-1] -real, parameter :: BET050 = 0.5*EOS150*r1_S0 ! Coefficient of the drho_dS fit zt**5 term [kg m-3 ppt-1] -real, parameter :: BET001 = 0.5*EOS101*r1_S0 ! Coefficient of the drho_dS fit zp term [kg m-3 ppt-1] -real, parameter :: BET101 = EOS201*r1_S0 ! Coefficient of the drho_dS fit zs * zp term [kg m-3 ppt-1] -real, parameter :: BET201 = 1.5*EOS301*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zp term [kg m-3 ppt-1] -real, parameter :: BET301 = 2.0*EOS401*r1_S0 ! Coefficient of the drho_dS fit zs**3 * zp term [kg m-3 ppt-1] -real, parameter :: BET011 = 0.5*EOS111*r1_S0 ! Coefficient of the drho_dS fit zt * zp term [kg m-3 ppt-1] -real, parameter :: BET111 = EOS211*r1_S0 ! Coefficient of the drho_dS fit zs * zt * zp term [kg m-3 ppt-1] -real, parameter :: BET211 = 1.5*EOS311*r1_S0 ! Coefficient of the drho_dS fit zs**2 * zt * zp term [kg m-3 ppt-1] -real, parameter :: BET021 = 0.5*EOS121*r1_S0 ! Coefficient of the drho_dS fit zt**2 * zp term [kg m-3 ppt-1] -real, parameter :: BET121 = EOS221*r1_S0 ! Coefficient of the drho_dS fit zs * zt**2 * zp term [kg m-3 ppt-1] -real, parameter :: BET031 = 0.5*EOS131*r1_S0 ! Coefficient of the drho_dS fit zt**3 * zp term [kg m-3 ppt-1] -real, parameter :: BET002 = 0.5*EOS102*r1_S0 ! Coefficient of the drho_dS fit zp**2 term [kg m-3 ppt-1] -real, parameter :: BET102 = EOS202*r1_S0 ! Coefficient of the drho_dS fit zs * zp**2 term [kg m-3 ppt-1] -real, parameter :: BET012 = 0.5*EOS112*r1_S0 ! Coefficient of the drho_dS fit zt * zp**2 term [kg m-3 ppt-1] -real, parameter :: BET003 = 0.5*EOS103*r1_S0 ! Coefficient of the drho_dS fit zp**3 term [kg m-3 ppt-1] +real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] + +! The following are the coefficients of the fit to the reference density profile (rho00p) as a function of +! pressure (P), with a contribution R0c * P**(c+1). The nomenclature follows Roquet. +real, parameter :: R00 = 4.6494977072e+01*Pa2kb ! rho00p P coef. [kg m-3 Pa-1] +real, parameter :: R01 = -5.2099962525*Pa2kb**2 ! rho00p P**2 coef. [kg m-3 Pa-2] +real, parameter :: R02 = 2.2601900708e-01*Pa2kb**3 ! rho00p P**3 coef. [kg m-3 Pa-3] +real, parameter :: R03 = 6.4326772569e-02*Pa2kb**4 ! rho00p P**4 coef. [kg m-3 Pa-4] +real, parameter :: R04 = 1.5616995503e-02*Pa2kb**5 ! rho00p P**5 coef. [kg m-3 Pa-5] +real, parameter :: R05 = -1.7243708991e-03*Pa2kb**6 ! rho00p P**6 coef. [kg m-3 Pa-6] + +! The following are coefficients of contributions to density as a function of the square root +! of normalized salinity with an offset (zs), temperature (T) and pressure (P), with a contribution +! EOSabc * zs**a * T**b * P**c. The numbers here are copied directly from Roquet et al. (2015), but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. +real, parameter :: EOS000 = 8.0189615746e+02 ! A constant density contribution [kg m-3] +real, parameter :: EOS100 = 8.6672408165e+02 ! EoS zs coef. [kg m-3] +real, parameter :: EOS200 = -1.7864682637e+03 ! EoS zs**2 coef. [kg m-3] +real, parameter :: EOS300 = 2.0375295546e+03 ! EoS zs**3 coef. [kg m-3] +real, parameter :: EOS400 = -1.2849161071e+03 ! EoS zs**4 coef. [kg m-3] +real, parameter :: EOS500 = 4.3227585684e+02 ! EoS zs**5 coef. [kg m-3] +real, parameter :: EOS600 = -6.0579916612e+01 ! EoS zs**6 coef. [kg m-3] +real, parameter :: EOS010 = 2.6010145068e+01*I_Ts ! EoS T coef. [kg m-3 degC-1] +real, parameter :: EOS110 = -6.5281885265e+01*I_Ts ! EoS zs * T coef. [kg m-3 degC-1] +real, parameter :: EOS210 = 8.1770425108e+01*I_Ts ! EoS zs**2 * T coef. [kg m-3 degC-1] +real, parameter :: EOS310 = -5.6888046321e+01*I_Ts ! EoS zs**3 * T coef. [kg m-3 degC-1] +real, parameter :: EOS410 = 1.7681814114e+01*I_Ts ! EoS zs**2 * T coef. [kg m-3 degC-1] +real, parameter :: EOS510 = -1.9193502195*I_Ts ! EoS zs**5 * T coef. [kg m-3 degC-1] +real, parameter :: EOS020 = -3.7074170417e+01*I_Ts**2 ! EoS T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS120 = 6.1548258127e+01*I_Ts**2 ! EoS zs * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS220 = -6.0362551501e+01*I_Ts**2 ! EoS zs**2 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS320 = 2.9130021253e+01*I_Ts**2 ! EoS zs**3 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS420 = -5.4723692739*I_Ts**2 ! EoS zs**4 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS030 = 2.1661789529e+01*I_Ts**3 ! EoS T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS130 = -3.3449108469e+01*I_Ts**3 ! EoS zs * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS230 = 1.9717078466e+01*I_Ts**3 ! EoS zs**2 * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS330 = -3.1742946532*I_Ts**3 ! EoS zs**3 * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS040 = -8.3627885467*I_Ts**4 ! EoS T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS140 = 1.1311538584e+01*I_Ts**4 ! EoS zs * T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS240 = -5.3563304045*I_Ts**4 ! EoS zs**2 * T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS050 = 5.4048723791e-01*I_Ts**5 ! EoS T**5 coef. [kg m-3 degC-5] +real, parameter :: EOS150 = 4.8169980163e-01*I_Ts**5 ! EoS zs * T**5 coef. [kg m-3 degC-5] +real, parameter :: EOS060 = -1.9083568888e-01*I_Ts**6 ! EoS T**6 [kg m-3 degC-6] +real, parameter :: EOS001 = 1.9681925209e+01*Pa2kb ! EoS P coef. [kg m-3 Pa-1] +real, parameter :: EOS101 = -4.2549998214e+01*Pa2kb ! EoS zs * P coef. [kg m-3 Pa-1] +real, parameter :: EOS201 = 5.0774768218e+01*Pa2kb ! EoS zs**2 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS301 = -3.0938076334e+01*Pa2kb ! EoS zs**3 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS401 = 6.6051753097*Pa2kb ! EoS zs**4 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS011 = -1.3336301113e+01*(I_Ts*Pa2kb) ! EoS T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS111 = -4.4870114575*(I_Ts*Pa2kb) ! EoS zs * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS211 = 5.0042598061*(I_Ts*Pa2kb) ! EoS zs**2 * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS311 = -6.5399043664e-01*(I_Ts*Pa2kb) ! EoS zs**3 * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS021 = 6.7080479603*(I_Ts**2*Pa2kb) ! EoS T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS121 = 3.5063081279*(I_Ts**2*Pa2kb) ! EoS zs * T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS221 = -1.8795372996*(I_Ts**2*Pa2kb) ! EoS zs**2 * T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS031 = -2.4649669534*(I_Ts**3*Pa2kb) ! EoS T**3 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: EOS131 = -5.5077101279e-01*(I_Ts**3*Pa2kb) ! EoS zs * T**3 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: EOS041 = 5.5927935970e-01*(I_Ts**4*Pa2kb) ! EoS T**4 * P coef. [kg m-3 degC-4 Pa-1] +real, parameter :: EOS002 = 2.0660924175*Pa2kb**2 ! EoS P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS102 = -4.9527603989*Pa2kb**2 ! EoS zs * P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS202 = 2.5019633244*Pa2kb**2 ! EoS zs**2 * P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS012 = 2.0564311499*(I_Ts*Pa2kb**2) ! EoS T * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: EOS112 = -2.1311365518e-01*(I_Ts*Pa2kb**2) ! EoS zs * T * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: EOS022 = -1.2419983026*(I_Ts**2*Pa2kb**2) ! EoS T**2 * P**2 coef. [kg m-3 degC-2 Pa-2] +real, parameter :: EOS003 = -2.3342758797e-02*Pa2kb**3 ! EoS P**3 coef. [kg m-3 Pa-3] +real, parameter :: EOS103 = -1.8507636718e-02*Pa2kb**3 ! EoS zs * P**3 coef. [kg m-3 Pa-3] +real, parameter :: EOS013 = 3.7969820455e-01*(I_Ts*Pa2kb**3) ! EoS T * P**3 coef. [kg m-3 degC-1 Pa-3] + +real, parameter :: ALP000 = EOS010 ! Constant in the drho_dT fit [kg m-3 degC-1] +real, parameter :: ALP100 = EOS110 ! drho_dT fit zs coef. [kg m-3 degC-1] +real, parameter :: ALP200 = EOS210 ! drho_dT fit zs**2 coef. [kg m-3 degC-1] +real, parameter :: ALP300 = EOS310 ! drho_dT fit zs**3 coef. [kg m-3 degC-1] +real, parameter :: ALP400 = EOS410 ! drho_dT fit zs**4 coef. [kg m-3 degC-1] +real, parameter :: ALP500 = EOS510 ! drho_dT fit zs**5 coef. [kg m-3 degC-1] +real, parameter :: ALP010 = 2.*EOS020 ! drho_dT fit T coef. [kg m-3 degC-2] +real, parameter :: ALP110 = 2.*EOS120 ! drho_dT fit zs * T coef. [kg m-3 degC-2] +real, parameter :: ALP210 = 2.*EOS220 ! drho_dT fit zs**2 * T coef. [kg m-3 degC-2] +real, parameter :: ALP310 = 2.*EOS320 ! drho_dT fit zs**3 * T coef. [kg m-3 degC-2] +real, parameter :: ALP410 = 2.*EOS420 ! drho_dT fit zs**4 * T coef. [kg m-3 degC-2] +real, parameter :: ALP020 = 3.*EOS030 ! drho_dT fit T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP120 = 3.*EOS130 ! drho_dT fit zs * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP220 = 3.*EOS230 ! drho_dT fit zs**2 * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP320 = 3.*EOS330 ! drho_dT fit zs**3 * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP030 = 4.*EOS040 ! drho_dT fit T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP130 = 4.*EOS140 ! drho_dT fit zs * T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP230 = 4.*EOS240 ! drho_dT fit zs**2 * T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP040 = 5.*EOS050 ! drho_dT fit T**4 coef. [kg m-3 degC-5] +real, parameter :: ALP140 = 5.*EOS150 ! drho_dT fit zs* * T**4 coef. [kg m-3 degC-5] +real, parameter :: ALP050 = 6.*EOS060 ! drho_dT fit T**5 coef. [kg m-3 degC-6] +real, parameter :: ALP001 = EOS011 ! drho_dT fit P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP101 = EOS111 ! drho_dT fit zs * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP201 = EOS211 ! drho_dT fit zs**2 * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP301 = EOS311 ! drho_dT fit zs**3 * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP011 = 2.*EOS021 ! drho_dT fit T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP111 = 2.*EOS121 ! drho_dT fit zs * T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP211 = 2.*EOS221 ! drho_dT fit zs**2 * T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP021 = 3.*EOS031 ! drho_dT fit T**2 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: ALP121 = 3.*EOS131 ! drho_dT fit zs * T**2 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: ALP031 = 4.*EOS041 ! drho_dT fit T**3 * P coef. [kg m-3 degC-4 Pa-1] +real, parameter :: ALP002 = EOS012 ! drho_dT fit P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: ALP102 = EOS112 ! drho_dT fit zs * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: ALP012 = 2.*EOS022 ! drho_dT fit T * P**2 coef. [kg m-3 degC-2 Pa-2] +real, parameter :: ALP003 = EOS013 ! drho_dT fit P**3 coef. [kg m-3 degC-1 Pa-3] + +real, parameter :: BET000 = 0.5*EOS100*r1_S0 ! Constant in the drho_dS fit [kg m-3 ppt-1] +real, parameter :: BET100 = EOS200*r1_S0 ! drho_dS fit zs coef. [kg m-3 ppt-1] +real, parameter :: BET200 = 1.5*EOS300*r1_S0 ! drho_dS fit zs**2 coef. [kg m-3 ppt-1] +real, parameter :: BET300 = 2.0*EOS400*r1_S0 ! drho_dS fit zs**3 coef. [kg m-3 ppt-1] +real, parameter :: BET400 = 2.5*EOS500*r1_S0 ! drho_dS fit zs**4 coef. [kg m-3 ppt-1] +real, parameter :: BET500 = 3.0*EOS600*r1_S0 ! drho_dS fit zs**5 coef. [kg m-3 ppt-1] +real, parameter :: BET010 = 0.5*EOS110*r1_S0 ! drho_dS fit T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET110 = EOS210*r1_S0 ! drho_dS fit zs * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET210 = 1.5*EOS310*r1_S0 ! drho_dS fit zs**2 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET310 = 2.0*EOS410*r1_S0 ! drho_dS fit zs**3 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET410 = 2.5*EOS510*r1_S0 ! drho_dS fit zs**4 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET020 = 0.5*EOS120*r1_S0 ! drho_dS fit T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET120 = EOS220*r1_S0 ! drho_dS fit zs * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET220 = 1.5*EOS320*r1_S0 ! drho_dS fit zs**2 * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET320 = 2.0*EOS420*r1_S0 ! drho_dS fit zs**3 * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET030 = 0.5*EOS130*r1_S0 ! drho_dS fit T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET130 = EOS230*r1_S0 ! drho_dS fit zs * T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET230 = 1.5*EOS330*r1_S0 ! drho_dS fit zs**2 * T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET040 = 0.5*EOS140*r1_S0 ! drho_dS fit T**4 coef. [kg m-3 ppt-1 degC-4] +real, parameter :: BET140 = EOS240*r1_S0 ! drho_dS fit zs * T**4 coef. [kg m-3 ppt-1 degC-4] +real, parameter :: BET050 = 0.5*EOS150*r1_S0 ! drho_dS fit T**5 coef. [kg m-3 ppt-1 degC-5] +real, parameter :: BET001 = 0.5*EOS101*r1_S0 ! drho_dS fit P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET101 = EOS201*r1_S0 ! drho_dS fit zs * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET201 = 1.5*EOS301*r1_S0 ! drho_dS fit zs**2 * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET301 = 2.0*EOS401*r1_S0 ! drho_dS fit zs**3 * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET011 = 0.5*EOS111*r1_S0 ! drho_dS fit T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET111 = EOS211*r1_S0 ! drho_dS fit zs * T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET211 = 1.5*EOS311*r1_S0 ! drho_dS fit zs**2 * T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET021 = 0.5*EOS121*r1_S0 ! drho_dS fit T**2 * P coef. [kg m-3 ppt-1 degC-2 Pa-1] +real, parameter :: BET121 = EOS221*r1_S0 ! drho_dS fit zs * T**2 * P coef. [kg m-3 ppt-1 degC-2 Pa-1] +real, parameter :: BET031 = 0.5*EOS131*r1_S0 ! drho_dS fit T**3 * P coef. [kg m-3 ppt-1 degC-3 Pa-1] +real, parameter :: BET002 = 0.5*EOS102*r1_S0 ! drho_dS fit P**2 coef. [kg m-3 ppt-1 Pa-2] +real, parameter :: BET102 = EOS202*r1_S0 ! drho_dS fit zs * P**2 coef. [kg m-3 ppt-1 Pa-2] +real, parameter :: BET012 = 0.5*EOS112*r1_S0 ! drho_dS fit T * P**2 coef. [kg m-3 ppt-1 degC-1 Pa-2] +real, parameter :: BET003 = 0.5*EOS103*r1_S0 ! drho_dS fit P**3 coef. [kg m-3 ppt-1 Pa-3] !>@} contains @@ -177,23 +182,23 @@ module MOM_EOS_Roquet_rho !> This subroutine computes the in situ density of sea water (rho in [kg m-3]) !! from absolute salinity (S [g kg-1]), conservative temperature (T [degC]) !! and pressure [Pa], using the density polynomial fit EOS from Roquet et al. (2015). -subroutine calculate_density_scalar_Roquet_rho(T, S, pressure, rho, rho_ref) +subroutine calculate_density_scalar_Roquet_rho(T, S, pres, rho, rho_ref) real, intent(in) :: T !< Conservative temperature [degC] real, intent(in) :: S !< Absolute salinity [g kg-1] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pres !< Pressure [Pa] real, intent(out) :: rho !< In situ density [kg m-3] real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] - real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: pres0 ! A 1-d array with a copy of the pressure [Pa] real, dimension(1) :: rho0 ! A 1-d array with a copy of the density [kg m-3] T0(1) = T S0(1) = S - pressure0(1) = pressure + pres0(1) = pres - call calculate_density_array_Roquet_rho(T0, S0, pressure0, rho0, 1, 1, rho_ref) + call calculate_density_array_Roquet_rho(T0, S0, pres0, rho0, 1, 1, rho_ref) rho = rho0(1) end subroutine calculate_density_scalar_Roquet_rho @@ -201,40 +206,41 @@ end subroutine calculate_density_scalar_Roquet_rho !> This subroutine computes an array of in situ densities of sea water (rho in [kg m-3]) !! from absolute salinity (S [g kg-1]), conservative temperature (T [degC]), and pressure !! [Pa], using the density polynomial fit EOS from Roquet et al. (2015). -subroutine calculate_density_array_Roquet_rho(T, S, pressure, rho, start, npts, rho_ref) +subroutine calculate_density_array_Roquet_rho(T, S, pres, rho, start, npts, rho_ref) real, dimension(:), intent(in) :: T !< Conservative temperature [degC] real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: pres !< Pressure [Pa] real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] integer, intent(in) :: start !< The starting index for calculations integer, intent(in) :: npts !< The number of values to calculate real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] ! Local variables - real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] - real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized - ! by an assumed salinity range [nondim] + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] real :: rho00p ! A pressure-dependent but temperature and salinity independent contribution to ! density at the reference temperature and salinity [kg m-3] real :: rhoTS ! Density without a pressure-dependent contribution [kg m-3] - real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the surface pressure [kg m-3] - real :: rhoTS1 ! A temperature and salinity dependent density contribution proportional to pressure [kg m-3] - real :: rhoTS2 ! A temperature and salinity dependent density contribution proportional to pressure**2 [kg m-3] - real :: rhoTS3 ! A temperature and salinity dependent density contribution proportional to pressure**3 [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] integer :: j ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. do j=start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = pres(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) @@ -243,7 +249,7 @@ subroutine calculate_density_array_Roquet_rho(T, S, pressure, rho, start, npts, rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & - + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) rhoTS0 = zt*(EOS010 & + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & @@ -265,10 +271,10 @@ end subroutine calculate_density_array_Roquet_rho !> For a given thermodynamic state, calculate the derivatives of density with conservative !! temperature and absolute salinity, using the density polynomial fit EOS from Roquet et al. (2015). -subroutine calculate_density_derivs_array_Roquet_rho(T, S, pressure, drho_dT, drho_dS, start, npts) +subroutine calculate_density_derivs_array_Roquet_rho(T, S, pres, drho_dT, drho_dS, start, npts) real, intent(in), dimension(:) :: T !< Conservative temperature [degC] real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] - real, intent(in), dimension(:) :: pressure !< Pressure [Pa] + real, intent(in), dimension(:) :: pres !< Pressure [Pa] real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with !! conservative temperature [kg m-3 degC-1] real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with @@ -277,37 +283,37 @@ subroutine calculate_density_derivs_array_Roquet_rho(T, S, pressure, drho_dT, dr integer, intent(in) :: npts !< The number of values to calculate ! Local variables - real :: zp ! Pressure, first in [dbar], then normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature, first in [degC], then normalized by an assumed temperature range [nondim] - real :: zs ! Absolute salinity, first in [g kg-1], then the square root of salinity with an offset normalized - ! by an assumed salinity range [nondim] + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] real :: dRdzt0 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] ! from temperature anomalies at the surface pressure - real :: dRdzt1 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + real :: dRdzt1 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-1] ! proportional to pressure - real :: dRdzt2 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + real :: dRdzt2 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-2] ! proportional to pressure**2 - real :: dRdzt3 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + real :: dRdzt3 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-3] ! proportional to pressure**3 real :: dRdzs0 ! A contribution to the partial derivative of density with ! salinity [kg m-3 ppt-1] from temperature anomalies at the surface pressure real :: dRdzs1 ! A contribution to the partial derivative of density with - ! salinity [kg m-3 ppt-1] proportional to pressure + ! salinity [kg m-3 ppt-1 Pa-1] proportional to pressure real :: dRdzs2 ! A contribution to the partial derivative of density with - ! salinity [kg m-3 ppt-1] proportional to pressure**2 + ! salinity [kg m-3 ppt-1 Pa-2] proportional to pressure**2 real :: dRdzs3 ! A contribution to the partial derivative of density with - ! salinity [kg m-3 ppt-1] proportional to pressure**3 + ! salinity [kg m-3 ppt-1 Pa-3] proportional to pressure**3 integer :: j do j=start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = pres(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. ! Find the partial derivative of density with temperature @@ -343,10 +349,10 @@ subroutine calculate_density_derivs_array_Roquet_rho(T, S, pressure, drho_dT, dr end subroutine calculate_density_derivs_array_Roquet_rho !> Wrapper to calculate_density_derivs_array for scalar inputs -subroutine calculate_density_derivs_scalar_Roquet_rho(T, S, pressure, drho_dt, drho_ds) +subroutine calculate_density_derivs_scalar_Roquet_rho(T, S, pres, drho_dt, drho_ds) real, intent(in) :: T !< Conservative temperature [degC] real, intent(in) :: S !< Absolute salinity [g kg-1] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pres !< Pressure [Pa] real, intent(out) :: drho_dT !< The partial derivative of density with !! conservative temperature [kg m-3 degC-1] real, intent(out) :: drho_dS !< The partial derivative of density with @@ -354,7 +360,7 @@ subroutine calculate_density_derivs_scalar_Roquet_rho(T, S, pressure, drho_dt, d ! Local variables real, dimension(1) :: T0 ! A 1-d array with a copy of the conservative temperature [degC] real, dimension(1) :: S0 ! A 1-d array with a copy of the absolute salinity [g kg-1] - real, dimension(1) :: pressure0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: pres0 ! A 1-d array with a copy of the pressure [Pa] real, dimension(1) :: drdt0 ! A 1-d array with a copy of the derivative of density ! with conservative temperature [kg m-3 degC-1] real, dimension(1) :: drds0 ! A 1-d array with a copy of the derivative of density @@ -362,9 +368,9 @@ subroutine calculate_density_derivs_scalar_Roquet_rho(T, S, pressure, drho_dt, d T0(1) = T S0(1) = S - pressure0(1) = pressure + pres0(1) = pres - call calculate_density_derivs_array_Roquet_rho(T0, S0, pressure0, drdt0, drds0, 1, 1) + call calculate_density_derivs_array_Roquet_rho(T0, S0, pres0, drdt0, drds0, 1, 1) drho_dt = drdt0(1) drho_ds = drds0(1) end subroutine calculate_density_derivs_scalar_Roquet_rho @@ -373,10 +379,10 @@ end subroutine calculate_density_derivs_scalar_Roquet_rho !! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), !! conservative temperature (T [degC]), and pressure [Pa], using the density polynomial !! fit EOS from Roquet et al. (2015). -subroutine calculate_compress_Roquet_rho(T, S, pressure, rho, drho_dp, start, npts) +subroutine calculate_compress_Roquet_rho(T, S, pres, rho, drho_dp, start, npts) real, intent(in), dimension(:) :: T !< Conservative temperature [degC] real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1] - real, intent(in), dimension(:) :: pressure !< Pressure [Pa] + real, intent(in), dimension(:) :: pres !< Pressure [Pa] real, intent(out), dimension(:) :: rho !< In situ density [kg m-3] real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) @@ -385,31 +391,33 @@ subroutine calculate_compress_Roquet_rho(T, S, pressure, rho, drho_dp, start, np integer, intent(in) :: npts !< The number of values to calculate ! Local variables - real :: zp ! Pressure normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] - real :: zs ! The square root of absolute salinity with an offset normalized - ! by an assumed salinity range [nondim] - real :: drho00p_dp ! Derivative of the pressure-dependent reference density profile with normalized pressure [kg m-3] - real :: drhoTS_dp ! Derivative of the density anomaly from the reference profile with normalized pressure [kg m-3] - real :: rho00p ! The pressure-dependent (but temperature and salinity independent) reference density profile [kg m-3] + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: drho00p_dp ! Derivative of the pressure-dependent reference density profile with pressure [kg m-3 Pa-1] + real :: drhoTS_dp ! Derivative of the density anomaly from the reference profile with pressure [kg m-3 Pa-1] + real :: rho00p ! The pressure-dependent (but temperature and salinity independent) reference + ! density profile [kg m-3] real :: rhoTS ! Density anomaly from the reference profile [kg m-3] - real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the surface pressure [kg m-3] - real :: rhoTS1 ! A temperature and salinity dependent density contribution proportional to pressure [kg m-3] - real :: rhoTS2 ! A temperature and salinity dependent density contribution proportional to pressure**2 [kg m-3] - real :: rhoTS3 ! A temperature and salinity dependent density contribution proportional to pressure**3 [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] integer :: j ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. do j=start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = pressure(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = pres(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) @@ -418,7 +426,7 @@ subroutine calculate_compress_Roquet_rho(T, S, pressure, rho, drho_dp, start, np rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & - + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) rhoTS0 = zt*(EOS010 & + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & @@ -436,18 +444,19 @@ subroutine calculate_compress_Roquet_rho(T, S, pressure, rho, drho_dp, start, np drho00p_dp = R00 + zp*(2.*R01 + zp*(3.*R02 + zp*(4.*R03 + zp*(5.*R04 + zp*(6.*R05))))) drhoTS_dp = rhoTS1 + zp*(2.*rhoTS2 + zp*(3.*rhoTS3)) - drho_dp(j) = (drhoTS_dp + drho00p_dp) * (Pa2db*r1_P0) ! Compressibility [s2 m-2] + drho_dp(j) = drhoTS_dp + drho00p_dp ! Compressibility [s2 m-2] enddo end subroutine calculate_compress_Roquet_rho -!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array inputs and outputs. +!> Second derivatives of density with respect to temperature, salinity, and pressure for 1-d array +!! inputs and outputs. subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp, start, npts) - real, dimension(:), intent(in ) :: T !< Conservative temperature [degC] - real, dimension(:), intent(in ) :: S !< Absolute salinity [PSU] - real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent(in ) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in ) :: S !< Absolute salinity [g kg-1] = [ppt] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] real, dimension(:), intent(inout) :: drho_ds_ds !< Second derivative of density with respect !! to salinity [kg m-3 ppt-2] real, dimension(:), intent(inout) :: drho_ds_dt !< Second derivative of density with respect @@ -458,15 +467,15 @@ subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] real, dimension(:), intent(inout) :: drho_dt_dp !< Second derivative of density with respect to pressure !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] - integer, intent(in ) :: start !< Starting index in T,S,P - integer, intent(in ) :: npts !< Number of points to loop over + integer, intent(in ) :: start !< The starting index for calculations + integer, intent(in ) :: npts !< The number of values to calculate ! Local variables - real :: zp ! Pressure normalized by an assumed pressure range [nondim] - real :: zt ! Conservative temperature normalized by an assumed temperature range [nondim] - real :: zs ! The square root of absolute salinity with an offset normalized - ! by an assumed salinity range [nondim] - real :: I_s ! The inverse of zs [nondim] + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: I_s ! The inverse of zs [nondim] real :: d2R_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] real :: d2R_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] real :: d2R_p2 ! A contribution to one of the second derivatives that is proportional to pressure**2 [various] @@ -475,13 +484,13 @@ subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, do j = start,start+npts-1 ! Conversions to the units used here. - zt = T(j) * r1_T0 ! Conservative temperature normalized by a plausible oceanic range [nondim] + zt = T(j) zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] - zp = P(j) * (Pa2db*r1_P0) ! Convert pressure from Pascals to kilobars to normalize it [nondim] + zp = P(j) ! The next two lines should be used if it is necessary to convert potential temperature and ! practical salinity to conservative temperature and absolute salinity. - ! zt = r1_T0 * gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] + ! zt = gsw_ct_from_pt(S(j),T(j)) ! Convert potential temp to conservative temp [degC] ! zs = SQRT( ABS( gsw_sr_from_sp(S(j)) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. I_s = 1.0 / zs @@ -506,7 +515,7 @@ subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, + zt*(3.*EOS130 + (zs*(6.*EOS230 + zs*(9.*EOS330)) & + zt*(4.*EOS140 + (zs*(8.*EOS240) & + zt*(5.*EOS150))) )) )) ) - drho_ds_dt(j) = (0.5*r1_S0*r1_T0) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) + drho_ds_dt(j) = (0.5*r1_S0) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) ! Find drho_dt_dt d2R_p2 = 2.*EOS022 @@ -517,7 +526,7 @@ subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, + zt*(12.*EOS040 + (zs*(12.*EOS140 + zs *(12.*EOS240)) & + zt*(20.*EOS050 + (zs*(20.*EOS150) & + zt*(30.*EOS060) )) )) )) ) - drho_dt_dt(j) = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * r1_T0**2 + drho_dt_dt(j) = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) ! Find drho_ds_dp d2R_p2 = 3.*EOS103 @@ -525,7 +534,7 @@ subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, d2R_p0 = EOS101 + (zs*(2.*EOS201 + zs*(3.*EOS301 + zs*(4.*EOS401))) & + zt*(EOS111 + (zs*(2.*EOS211 + zs*(3.*EOS311)) & + zt*( EOS121 + (zs*(2.*EOS221) + zt*EOS131)) )) ) - drho_ds_dp(j) = ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) * (0.5*r1_S0 * Pa2db*r1_P0) + drho_ds_dp(j) = ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) * (0.5*r1_S0) ! Find drho_dt_dp d2R_p2 = 3.*EOS013 @@ -533,7 +542,7 @@ subroutine calculate_density_second_derivs_array_Roquet_rho(T, S, P, drho_ds_ds, d2R_p0 = EOS011 + (zs*(EOS111 + zs*( EOS211 + zs* EOS311)) & + zt*(2.*EOS021 + (zs*(2.*EOS121 + zs*(2.*EOS221)) & + zt*(3.*EOS031 + (zs*(3.*EOS131) + zt*(4.*EOS041))) )) ) - drho_dt_dp(j) = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * (Pa2db*r1_P0* r1_T0) + drho_dt_dp(j) = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) enddo end subroutine calculate_density_second_derivs_array_Roquet_rho @@ -545,7 +554,7 @@ end subroutine calculate_density_second_derivs_array_Roquet_rho subroutine calculate_density_second_derivs_scalar_Roquet_rho(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp) real, intent(in ) :: T !< Conservative temperature [degC] - real, intent(in ) :: S !< Absolute salinity [PSU] + real, intent(in ) :: S !< Absolute salinity [g kg-1] real, intent(in ) :: P !< pressure [Pa] real, intent( out) :: drho_ds_ds !< Second derivative of density with respect !! to salinity [kg m-3 ppt-2] @@ -558,15 +567,15 @@ subroutine calculate_density_second_derivs_scalar_Roquet_rho(T, S, P, drho_ds_ds real, intent( out) :: drho_dt_dp !< Second derivative of density with respect to pressure !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] ! Local variables - real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] - real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [PSU] - real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] - real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 PSU-2] + real, dimension(1) :: T0 ! A 1-d array with a copy of the temperature [degC] + real, dimension(1) :: S0 ! A 1-d array with a copy of the salinity [g kg-1] = [ppt] + real, dimension(1) :: p0 ! A 1-d array with a copy of the pressure [Pa] + real, dimension(1) :: drdsds ! The second derivative of density with salinity [kg m-3 ppt-2] real, dimension(1) :: drdsdt ! The second derivative of density with salinity and - ! temperature [kg m-3 PSU-1 degC-1] + ! temperature [kg m-3 ppt-1 degC-1] real, dimension(1) :: drdtdt ! The second derivative of density with temperature [kg m-3 degC-2] real, dimension(1) :: drdsdp ! The second derivative of density with salinity and - ! pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + ! pressure [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] real, dimension(1) :: drdtdp ! The second derivative of density with temperature and ! pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] From 28f97bbb1354f5202a8b2aab4d61296fd6b73b80 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Mar 2023 23:10:30 -0400 Subject: [PATCH 63/91] +Add calculate_TFreeze_TEOS_poly Added the overloaded interface calculate_TFreeze_TEOS_poly to MOM_TFreeze to use the 23-term polynomial expression from TEOS-10 for the freezing point in conservative temperature as a function of pressure and absolute salinity. This gives results that agrees to within about 5e-4 degC with the algorithm used by calculate_TFreeze_TEOS10, which calls the gsw TEOS10 code that does an iterative inversion of a balance of chemical potentials to find the freezing point (see the TEOS10 documentation for more details). Also added testing for the freezing point calculations to the EOS_unit tests via the new internal subroutine test_TFr_consistency. This new freezing point calculation is invoked by setting TFREEZE_FORM = TEOS_POLY. By default, all answers are bitwise identical, but there are some minor changes in the comments in some MOM_parameter_doc files, and there are several new interfaces. --- src/equation_of_state/MOM_EOS.F90 | 132 +++++++++++++++++++++++--- src/equation_of_state/MOM_TFreeze.F90 | 97 ++++++++++++++++--- 2 files changed, 204 insertions(+), 25 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 1a1668e63b..3da471ce7e 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -48,7 +48,7 @@ module MOM_EOS use MOM_EOS_TEOS10, only : EoS_fit_range_TEOS10 use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero -use MOM_TFreeze, only : calculate_TFreeze_teos10 +use MOM_TFreeze, only : calculate_TFreeze_teos10, calculate_TFreeze_TEOS_poly use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type @@ -197,8 +197,11 @@ module MOM_EOS integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression integer, parameter :: TFREEZE_MILLERO = 2 !< A named integer specifying a freezing point expression integer, parameter :: TFREEZE_TEOS10 = 3 !< A named integer specifying a freezing point expression +integer, parameter :: TFREEZE_TEOSPOLY = 4 !< A named integer specifying a freezing point expression character*(10), parameter :: TFREEZE_LINEAR_STRING = "LINEAR" !< A string for specifying the freezing point expression -character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" !< A string for specifying +character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" !< A string for specifying the + !! freezing point expression +character*(10), parameter :: TFREEZE_TEOSPOLY_STRING = "TEOS_POLY" !< A string for specifying the !! freezing point expression character*(10), parameter :: TFREEZE_TEOS10_STRING = "TEOS10" !< A string for specifying the freezing point expression @@ -794,6 +797,8 @@ subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale, scale_fr EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) call calculate_TFreeze_Millero(S_scale*S, p_scale*pressure, T_fr) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S_scale*S, p_scale*pressure, T_fr) case (TFREEZE_TEOS10) call calculate_TFreeze_teos10(S_scale*S, p_scale*pressure, T_fr) case default @@ -832,6 +837,8 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) call calculate_TFreeze_Millero(S, pressure, T_fr, start, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S, pressure, T_fr, start, npts) case (TFREEZE_TEOS10) call calculate_TFreeze_teos10(S, pressure, T_fr, start, npts) case default @@ -847,6 +854,8 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca call calculate_TFreeze_Millero(S, pres, T_fr, start, npts) case (TFREEZE_TEOS10) call calculate_TFreeze_teos10(S, pres, T_fr, start, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S, pres, T_fr, start, npts) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select @@ -883,6 +892,8 @@ subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) call calculate_TFreeze_Millero(S, pressure, T_fr, is, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S, pressure, T_fr, is, npts) case (TFREEZE_TEOS10) call calculate_TFreeze_teos10(S, pressure, T_fr, is, npts) case default @@ -899,6 +910,8 @@ subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) call calculate_TFreeze_Millero(Sa, pres, T_fr, is, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(Sa, pres, T_fr, is, npts) case (TFREEZE_TEOS10) call calculate_TFreeze_teos10(Sa, pres, T_fr, is, npts) case default @@ -1863,13 +1876,15 @@ subroutine EOS_init(param_file, EOS, US) call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & "TFREEZE_FORM determines which expression should be "//& "used for the freezing point. Currently, the valid "//& - 'choices are "LINEAR", "MILLERO_78", "TEOS10"', & + 'choices are "LINEAR", "MILLERO_78", "TEOS_POLY", "TEOS10"', & default=TFREEZE_DEFAULT) select case (uppercase(tmpstr)) case (TFREEZE_LINEAR_STRING) EOS%form_of_TFreeze = TFREEZE_LINEAR case (TFREEZE_MILLERO_STRING) EOS%form_of_TFreeze = TFREEZE_MILLERO + case (TFREEZE_TEOSPOLY_STRING) + EOS%form_of_TFreeze = TFREEZE_TEOSPOLY case (TFREEZE_TEOS10_STRING) EOS%form_of_TFreeze = TFREEZE_TEOS10 case default @@ -1896,9 +1911,9 @@ subroutine EOS_init(param_file, EOS, US) if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & - (EOS%form_of_TFreeze /= TFREEZE_TEOS10)) then + .not.((EOS%form_of_TFreeze == TFREEZE_TEOS10) .or. (EOS%form_of_TFreeze == TFREEZE_TEOSPOLY)) ) then call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_ROQUET_RHO or EOS_ROQUET_SPV "//& - "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") + "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 or TFREEZE_TEOSPOLY.") endif ! Unit conversions @@ -2227,23 +2242,112 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "LINEAR EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail + ! Test the freezing point calculations + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_LINEAR, TFr_S0_P0=0.0, dTFr_dS=-0.054, & + dTFr_dP=-7.6e-8) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", TFr_check=-2.65*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "LINEAR TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_MILLERO) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "MILLERO_78", & + TFr_check=-2.69730134114106*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "MILLERO_78 TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_TEOS10) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", & + TFr_check=-2.69099996992861*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_TEOSPOLY) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "TEOS_POLY", & + TFr_check=-2.691165259327735*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS_POLY TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + if (verbose .and. .not.EOS_unit_tests) call MOM_mesg("All EOS consistency tests have passed.") end function EOS_unit_tests +logical function test_TFr_consistency(S_test, p_test, EOS, verbose, EOS_name, TFr_check) & + result(inconsistent) + real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] + real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: EOS_name !< A name used in error messages to describe the EoS + real, optional, intent(in) :: TFr_check !< A check value for the Freezing point [C ~> degC] + + ! Local variables + real, dimension(-3:3,-3:3) :: S ! Salinities at the test value and perturbed points [S ~> ppt] + real, dimension(-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] + real, dimension(-3:3,-3:3,2) :: TFr ! Freezing point at the test value and perturbed points [C ~> degC] + character(len=200) :: mesg + real :: dS ! Magnitude of salinity perturbations [S ~> ppt] + real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa] + ! real :: tol ! The nondimensional tolerance from roundoff [nondim] + real :: TFr_tol ! Roundoff error on a typical value of TFreeze [C ~> degC] + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + integer :: i, j, n + + OK = .true. + + dS = 0.5*EOS%ppt_to_S ! Salinity perturbations [S ~> ppt] + dp = 10.0e4 / EOS%RL2_T2_to_Pa ! Pressure perturbations [R L2 T-2 ~> Pa] + + ! TEOS 10 requires a tolerance that is ~20 times larger than other freezing point + ! expressions because it lacks parentheses. + TFr_tol = 2.0*EOS%degC_to_C * 400.0*epsilon(TFr_tol) + + do n=1,2 + ! Calculate density values with a wide enough stencil to estimate first and second derivatives + ! with up to 6th order accuracy. Doing this twice with different sizes of perturbations allows + ! the evaluation of whether the finite differences are converging to the calculated values at a + ! rate that is consistent with the order of accuracy of the finite difference forms, and hence + ! the consistency of the calculated values. + do j=-3,3 ; do i=-3,3 + S(i,j) = max(S_test + n*dS*i, 0.0) + p(i,j) = max(p_test + n*dp*j, 0.0) + enddo ; enddo + do j=-3,3 + call calculate_TFreeze(S(:,j), p(:,j), TFr(:,j,n), EOS) + enddo + enddo + + ! Check that the freezing point agrees with the provided check value + if (present(TFr_check)) then + test_OK = (abs(TFr_check - TFr(0,0,1)) <= TFr_tol) + OK = OK .and. test_OK + if (verbose) then + write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & + TFr(0,0,1), TFr_check, TFr(0,0,1)-TFr_check, TFr_tol + if (test_OK) then + call MOM_mesg(trim(EOS_name)//" TFr agrees with its check value :"//trim(mesg)) + else + call MOM_error(WARNING, trim(EOS_name)//" TFr disagrees with its check value :"//trim(mesg)) + endif + endif + endif + + inconsistent = .not.OK +end function test_TFr_consistency + !> Test an equation of state for self-consistency and consistency with check values, returning false !! if it is consistent by all tests, and true if it fails any test. logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & EOS_name, rho_check, spv_check, skip_2nd) result(inconsistent) - real, intent(in) :: T_test !< Potential temperature or conservative temperature [C ~> degC] - real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] - real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] - type(EOS_type), intent(in) :: EOS !< Equation of state structure - logical, intent(in) :: verbose !< If true, write results to stdout - character(len=*), & - optional, intent(in) :: EOS_name !< A name used in error messages to describe the EoS - real, optional, intent(in) :: rho_check !< A check value for the density [R ~> kg m-3] - real, optional, intent(in) :: spv_check !< A check value for the specific volume [R-1 ~> m3 kg-1] + real, intent(in) :: T_test !< Potential temperature or conservative temperature [C ~> degC] + real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] + real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: EOS_name !< A name used in error messages to describe the EoS + real, optional, intent(in) :: rho_check !< A check value for the density [R ~> kg m-3] + real, optional, intent(in) :: spv_check !< A check value for the specific volume [R-1 ~> m3 kg-1] logical, optional, intent(in) :: skip_2nd !< If present and true, do not check the 2nd derivatives. ! Local variables diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index 16a64c89ed..faa103d094 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -5,13 +5,14 @@ module MOM_TFreeze !********+*********+*********+*********+*********+*********+*********+** !* The subroutines in this file determine the potential temperature * -!* at which sea-water freezes. * +!* or conservative temperature at which sea-water freezes. * !********+*********+*********+*********+*********+*********+*********+** use gsw_mod_toolbox, only : gsw_ct_freezing_exact implicit none ; private public calculate_TFreeze_linear, calculate_TFreeze_Millero, calculate_TFreeze_teos10 +public calculate_TFreeze_TEOS_poly !> Compute the freezing point potential temperature [degC] from salinity [ppt] and !! pressure [Pa] using a simple linear expression, with coefficients passed in as arguments. @@ -34,11 +35,17 @@ module MOM_TFreeze module procedure calculate_TFreeze_teos10_scalar, calculate_TFreeze_teos10_array end interface calculate_TFreeze_teos10 +!> Compute the freezing point conservative temperature [degC] from absolute salinity [g kg-1] and +!! pressure [Pa] using a rescaled and refactored version of the expressions from the TEOS10 package. +interface calculate_TFreeze_TEOS_poly + module procedure calculate_TFreeze_TEOS_poly_scalar, calculate_TFreeze_TEOS_poly_array +end interface calculate_TFreeze_TEOS_poly + contains -!> This subroutine computes the freezing point potential temperature -!! [degC] from salinity [ppt], and pressure [Pa] using a simple -!! linear expression, with coefficients passed in as arguments. +!> This subroutine computes the freezing point potential temperature [degC] from +!! salinity [ppt], and pressure [Pa] using a simple linear expression, +!! with coefficients passed in as arguments. subroutine calculate_TFreeze_linear_scalar(S, pres, T_Fr, TFr_S0_P0, & dTFr_dS, dTFr_dp) real, intent(in) :: S !< salinity [ppt]. @@ -66,7 +73,7 @@ subroutine calculate_TFreeze_linear_array(S, pres, T_Fr, start, npts, & integer, intent(in) :: npts !< the number of values to calculate. real, intent(in) :: TFr_S0_P0 !< The freezing point at S=0, p=0, [degC]. real, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity, - !! [degC PSU-1]. + !! [degC ppt-1]. real, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure, !! [degC Pa-1]. integer :: j @@ -94,13 +101,13 @@ subroutine calculate_TFreeze_Millero_scalar(S, pres, T_Fr) real, parameter :: cS2 = -2.154996e-4 ! A term in the freezing point fit [degC PSU-2] real, parameter :: dTFr_dp = -7.75e-8 ! Derivative of freezing point with pressure [degC Pa-1] - T_Fr = S*(cS1 + (cS3_2 * sqrt(max(S,0.0)) + cS2 * S)) + dTFr_dp*pres + T_Fr = S*(cS1 + (cS3_2 * sqrt(max(S, 0.0)) + cS2 * S)) + dTFr_dp*pres end subroutine calculate_TFreeze_Millero_scalar !> This subroutine computes the freezing point potential temperature !! [degC] from salinity [ppt], and pressure [Pa] using the expression -!! from Millero (1978) (and in appendix A of Gill 1982), but with the of the +!! from Millero (1978) (and in appendix A of Gill 1982), but with the !! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an !! expression for potential temperature (not in situ temperature), using a !! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). @@ -119,12 +126,82 @@ subroutine calculate_TFreeze_Millero_array(S, pres, T_Fr, start, npts) integer :: j do j=start,start+npts-1 - T_Fr(j) = S(j)*(cS1 + (cS3_2 * sqrt(max(S(j),0.0)) + cS2 * S(j))) + & + T_Fr(j) = S(j)*(cS1 + (cS3_2 * sqrt(max(S(j), 0.0)) + cS2 * S(j))) + & dTFr_dp*pres(j) enddo end subroutine calculate_TFreeze_Millero_array +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using a rescaled and +!! refactored version of the polynomial expressions from the TEOS10 package. +subroutine calculate_TFreeze_TEOS_poly_scalar(S, pres, T_Fr) + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pres !< Pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + + ! Local variables + real, dimension(1) :: S0 ! Salinity at a point [g kg-1] + real, dimension(1) :: pres0 ! Pressure at a point [Pa] + real, dimension(1) :: tfr0 ! The freezing temperature [degC] + + S0(1) = S + pres0(1) = pres + + call calculate_TFreeze_TEOS_poly_array(S0, pres0, tfr0, 1, 1) + T_Fr = tfr0(1) + +end subroutine calculate_TFreeze_TEOS_poly_scalar + +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using a rescaled and +!! refactored version of the polynomial expressions from the TEOS10 package. +subroutine calculate_TFreeze_TEOS_poly_array(S, pres, T_Fr, start, npts) + real, dimension(:), intent(in) :: S !< absolute salinity [g kg-1]. + real, dimension(:), intent(in) :: pres !< Pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + integer, intent(in) :: start !< The starting point in the arrays + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + real :: Sa ! Absolute salinity [g kg-1] = [ppt] + real :: rS ! Square root of salinity [ppt1/2] + ! The coefficients here use the notation TFab for contributions proportional to S**a/2 * P**b. + real, parameter :: TF00 = 0.017947064327968736 ! Freezing point coefficient [degC] + real, parameter :: TF20 = -6.076099099929818e-2 ! Freezing point coefficient [degC ppt-1] + real, parameter :: TF30 = 4.883198653547851e-3 ! Freezing point coefficient [degC ppt-3/2] + real, parameter :: TF40 = -1.188081601230542e-3 ! Freezing point coefficient [degC ppt-2] + real, parameter :: TF50 = 1.334658511480257e-4 ! Freezing point coefficient [degC ppt-5/2] + real, parameter :: TF60 = -8.722761043208607e-6 ! Freezing point coefficient [degC ppt-3] + real, parameter :: TF70 = 2.082038908808201e-7 ! Freezing point coefficient [degC ppt-7/2] + real, parameter :: TF01 = -7.389420998107497e-8 ! Freezing point coefficient [degC Pa-1] + real, parameter :: TF21 = -9.891538123307282e-11 ! Freezing point coefficient [degC ppt-1 Pa-1] + real, parameter :: TF31 = -8.987150128406496e-13 ! Freezing point coefficient [degC ppt-3/2 Pa-1] + real, parameter :: TF41 = 1.054318231187074e-12 ! Freezing point coefficient [degC ppt-2 Pa-1] + real, parameter :: TF51 = 3.850133554097069e-14 ! Freezing point coefficient [degC ppt-5/2 Pa-1] + real, parameter :: TF61 = -2.079022768390933e-14 ! Freezing point coefficient [degC ppt-3 Pa-1] + real, parameter :: TF71 = 1.242891021876471e-15 ! Freezing point coefficient [degC ppt-7/2 Pa-1] + real, parameter :: TF02 = -2.110913185058476e-16 ! Freezing point coefficient [degC Pa-2] + real, parameter :: TF22 = 3.831132432071728e-19 ! Freezing point coefficient [degC ppt-1 Pa-2] + real, parameter :: TF32 = 1.065556599652796e-19 ! Freezing point coefficient [degC ppt-3/2 Pa-2] + real, parameter :: TF42 = -2.078616693017569e-20 ! Freezing point coefficient [degC ppt-2 Pa-2] + real, parameter :: TF52 = 1.596435439942262e-21 ! Freezing point coefficient [degC ppt-5/2 Pa-2] + real, parameter :: TF03 = 2.295491578006229e-25 ! Freezing point coefficient [degC Pa-3] + real, parameter :: TF23 = -7.997496801694032e-27 ! Freezing point coefficient [degC ppt-1 Pa-3] + real, parameter :: TF33 = 8.756340772729538e-28 ! Freezing point coefficient [degC ppt-3/2 Pa-3] + real, parameter :: TF43 = 1.338002171109174e-29 ! Freezing point coefficient [degC ppt-2 Pa-3] + integer :: j + + do j=start,start+npts-1 + rS = sqrt(max(S(j), 0.0)) + T_Fr(j) = (TF00 + S(j)*(TF20 + rS*(TF30 + rS*(TF40 + rS*(TF50 + rS*(TF60 + rS*TF70)))))) & + + pres(j)*( (TF01 + S(j)*(TF21 + rS*(TF31 + rS*(TF41 + rS*(TF51 + rS*(TF61 + rS*TF71)))))) & + + pres(j)*((TF02 + S(j)*(TF22 + rS*(TF32 + rS*(TF42 + rS* TF52)))) & + + pres(j)*(TF03 + S(j)*(TF23 + rS*(TF33 + rS* TF43))) ) ) + enddo + +end subroutine calculate_TFreeze_TEOS_poly_array + !> This subroutine computes the freezing point conservative temperature [degC] !! from absolute salinity [g kg-1], and pressure [Pa] using the !! TEOS10 package. @@ -158,7 +235,6 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) ! Local variables real, parameter :: Pa2db = 1.e-4 ! The conversion factor from Pa to dbar [dbar Pa-1] - real :: zs ! Salinity at a point [g kg-1] real :: zp ! Pressures in [dbar] integer :: j ! Assume sea-water contains no dissolved air. @@ -166,11 +242,10 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) do j=start,start+npts-1 !Conversions - zs = S(j) zp = pres(j)* Pa2db !Convert pressure from Pascal to decibar if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? - T_Fr(j) = gsw_ct_freezing_exact(zs,zp,saturation_fraction) + T_Fr(j) = gsw_ct_freezing_exact(S(j), zp, saturation_fraction) enddo end subroutine calculate_TFreeze_teos10_array From 9e28271d59c77d69cfa447f516a099fdf4e3e2dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Mar 2023 07:00:03 -0400 Subject: [PATCH 64/91] +*Add MOM_temperature_convert.F90 Added the new module MOM_temperature_convert, which contains the elemental functions poTemp_to_consTemp and consTemp_to_poTemp to convert potential temperature to conservative temperature and the reverse. These routines are mathematically equivalent to the TEOS-10 functions gsw_ct_from_pt and gsw_pt_from_ct, but with some refactoring and added parentheses to help ensure identical answers across compilers or levels of optimization. Also added the new subroutines pot_temp_to_cons_temp and prac_saln_to_abs_saln, and added the new optional argument use_TEOS to convert_temp_salt_for_TEOS10, and cons_temp_to_pot_temp and abs_saln_to_prac_saln. The equivalency between the new code and their gsw_ counterparts is demonstrated in new tests in the new function test_TS_conversion_consistency, which in turn is called from EOS_unit_tests. All answers are mathematically equivalent, but because of the choice to use the new code by default there could be changes at the level of roundoff in some cases that use conservative temperature as their state variable but initialize it from potential temperature. There are not any such cases yet in the MOM6-examples test suite, nor are there believed to be any such MOM6 configurations that are widely used. This commit introduces a new module and several new functions or subroutines with public interfaces. --- src/equation_of_state/MOM_EOS.F90 | 346 +++++++++++++++--- .../MOM_temperature_convert.F90 | 166 +++++++++ 2 files changed, 458 insertions(+), 54 deletions(-) create mode 100644 src/equation_of_state/MOM_temperature_convert.F90 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 3da471ce7e..04b5e74c94 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -46,7 +46,8 @@ module MOM_EOS use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10, calculate_specvol_derivs_teos10 use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10, calculate_compress_teos10 use MOM_EOS_TEOS10, only : EoS_fit_range_TEOS10 -use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct +! use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_temperature_convert, only : poTemp_to_consTemp, consTemp_to_poTemp use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero use MOM_TFreeze, only : calculate_TFreeze_teos10, calculate_TFreeze_TEOS_poly use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg @@ -55,6 +56,8 @@ module MOM_EOS use MOM_io, only : stdout use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type +use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct +use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt implicit none ; private @@ -1988,7 +1991,7 @@ end subroutine EOS_use_linear !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 -subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) +subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS, use_TEOS) integer, intent(in) :: kd !< The number of layers to work on type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & @@ -1998,31 +2001,42 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & intent(in) :: mask_z !< 3d mask regulating which points to convert [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. real :: gsw_sr_from_sp ! Reference salinity after conversion from practical salinity [ppt] real :: gsw_ct_from_pt ! Conservative temperature after conversion from potential temperature [degC] + logical :: use_gsw ! If true, call gsw functions to do this conversion. + real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from + ! practical salinity to reference salinity [nondim] integer :: i, j, k if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_ROQUET_RHO) .and. & (EOS%form_of_EOS /= EOS_ROQUET_SPV)) return - do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - if (mask_z(i,j,k) >= 1.0) then - S(i,j,k) = EOS%ppt_to_S*gsw_sr_from_sp(EOS%S_to_ppt*S(i,j,k)) -! Get absolute salinity from practical salinity, converting pressures from Pascal to dbar. -! If this option is activated, pressure will need to be added as an argument, and it should be -! moved out into module that is not shared between components, where the ocean_grid can be used. -! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),pres(i,j,k)*1.0e-4,G%geoLonT(i,j),G%geoLatT(i,j)) - T(i,j,k) = EOS%degC_to_C*gsw_ct_from_pt(EOS%S_to_ppt*S(i,j,k), EOS%S_to_ppt*T(i,j,k)) - endif - enddo ; enddo ; enddo + use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS + + if (use_gsw) then + do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + if (mask_z(i,j,k) >= 1.0) then + S(i,j,k) = EOS%ppt_to_S*gsw_sr_from_sp(EOS%S_to_ppt*S(i,j,k)) + T(i,j,k) = EOS%degC_to_C*gsw_ct_from_pt(EOS%S_to_ppt*S(i,j,k), EOS%S_to_ppt*T(i,j,k)) + endif + enddo ; enddo ; enddo + else + do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + if (mask_z(i,j,k) >= 1.0) then + S(i,j,k) = Sref_Sprac * S(i,j,k) + T(i,j,k) = EOS%degC_to_C*poTemp_to_consTemp(EOS%S_to_ppt*S(i,j,k), EOS%S_to_ppt*T(i,j,k)) + endif + enddo ; enddo ; enddo + endif end subroutine convert_temp_salt_for_TEOS10 !> Converts an array of conservative temperatures to potential temperatures. The input arguments !! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. -subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) +subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale, use_TEOS) real, dimension(:), intent(in) :: T !< Conservative temperature [C ~> degC] real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] real, dimension(:), intent(inout) :: poTemp !< The potential temperature with a reference pressure @@ -2034,11 +2048,13 @@ subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) !! potential temperature in place of with scaling stored !! in EOS. A value of 1.0 returns temperatures in [degC], !! while the default is equivalent to EOS%degC_to_C. + logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. ! Local variables real, dimension(size(T)) :: Ta ! Temperature converted to [degC] real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] + logical :: use_gsw ! If true, call gsw functions to do this conversion. integer :: i, is, ie if (present(dom)) then @@ -2047,14 +2063,24 @@ subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) is = 1 ; ie = size(T) endif + use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then - poTemp(is:ie) = gsw_pt_from_ct(S(is:ie), T(is:ie)) + if (use_gsw) then + poTemp(is:ie) = gsw_pt_from_ct(S(is:ie), T(is:ie)) + else + poTemp(is:ie) = consTemp_to_poTemp(T(is:ie), S(is:ie)) + endif else do i=is,ie Ta(i) = EOS%C_to_degC * T(i) Sa(i) = EOS%S_to_ppt * S(i) enddo - poTemp(is:ie) = gsw_pt_from_ct(Sa(is:ie), Ta(is:ie)) + if (use_gsw) then + poTemp(is:ie) = gsw_pt_from_ct(Sa(is:ie), Ta(is:ie)) + else + poTemp(is:ie) = consTemp_to_poTemp(Ta(is:ie), Sa(is:ie)) + endif endif T_scale = EOS%degC_to_C @@ -2066,10 +2092,68 @@ subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) end subroutine cons_temp_to_pot_temp +!> Converts an array of potential temperatures to conservative temperatures. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine pot_temp_to_cons_temp(T, S, consTemp, EOS, dom, scale, use_TEOS) + real, dimension(:), intent(in) :: T !< Potential temperature [C ~> degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] + real, dimension(:), intent(inout) :: consTemp !< The conservative temperature [C ~> degC] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! potential temperature in place of with scaling stored + !! in EOS. A value of 1.0 returns temperatures in [degC], + !! while the default is equivalent to EOS%degC_to_C. + logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. + + ! Local variables + real, dimension(size(T)) :: Tp ! Potential temperature converted to [degC] + real, dimension(size(S)) :: Sa ! Absolute salinity converted to [ppt] + real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] + logical :: use_gsw ! If true, call gsw functions to do this conversion. + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(T) + endif + + use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS + + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + if (use_gsw) then + consTemp(is:ie) = gsw_ct_from_pt(S(is:ie), T(is:ie)) + else + consTemp(is:ie) = poTemp_to_consTemp(T(is:ie), S(is:ie)) + endif + else + do i=is,ie + Tp(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + if (use_gsw) then + consTemp(is:ie) = gsw_ct_from_pt(Sa(is:ie), Tp(is:ie)) + else + consTemp(is:ie) = poTemp_to_consTemp(Tp(is:ie), Sa(is:ie)) + endif + endif + + T_scale = EOS%degC_to_C + if (present(scale)) T_scale = scale + if (T_scale /= 1.0) then ; do i=is,ie + consTemp(i) = T_scale * consTemp(i) + enddo ; endif + +end subroutine pot_temp_to_cons_temp + + !> Converts an array of absolute salinity to practical salinity. The input arguments !! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. -subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) +subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale, use_TEOS) real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] real, dimension(:), intent(inout) :: prSaln !< Practical salinity [S ~> ppt] type(EOS_type), intent(in) :: EOS !< Equation of state structure @@ -2079,10 +2163,14 @@ subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) !! practical in place of with scaling stored !! in EOS. A value of 1.0 returns salinities in [PSU], !! while the default is equivalent to EOS%ppt_to_S. + logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. ! Local variables real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S ppt-1 ~> 1] + real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from + ! reference salinity to practical salinity [nondim] + logical :: use_gsw ! If true, call gsw functions to do this conversion. integer :: i, is, ie if (present(dom)) then @@ -2091,22 +2179,93 @@ subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) is = 1 ; ie = size(S) endif - if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then - prSaln(is:ie) = gsw_sp_from_sr(Sa(is:ie)) + use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS + + if (use_gsw) then + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + prSaln(is:ie) = gsw_sp_from_sr(S(is:ie)) + else + do i=is,ie ; Sa(i) = EOS%S_to_ppt * S(i) ; enddo + prSaln(is:ie) = gsw_sp_from_sr(Sa(is:ie)) + endif + + S_scale = EOS%ppt_to_S + if (present(scale)) S_scale = scale + if (S_scale /= 1.0) then ; do i=is,ie + prSaln(i) = S_scale * prSaln(i) + enddo ; endif + elseif (present(scale)) then + S_scale = Sprac_Sref * scale + do i=is,ie + prSaln(i) = S_scale * S(i) + enddo else - do i=is,ie ; Sa(i) = EOS%S_to_ppt * S(i) ; enddo - prSaln(is:ie) = gsw_sp_from_sr(Sa(is:ie)) + do i=is,ie + prSaln(i) = Sprac_Sref * S(i) + enddo endif - S_scale = EOS%ppt_to_S - if (present(scale)) S_scale = scale - if (S_scale /= 1.0) then ; do i=is,ie - prSaln(i) = S_scale * prSaln(i) - enddo ; endif - end subroutine abs_saln_to_prac_saln +!> Converts an array of absolute salinity to practical salinity. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale, use_TEOS) + real, dimension(:), intent(in) :: S !< Practical salinity [S ~> ppt] + real, dimension(:), intent(inout) :: absSaln !< Absolute salinity [S ~> ppt] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! practical in place of with scaling stored + !! in EOS. A value of 1.0 returns salinities in [PSU], + !! while the default is equivalent to EOS%ppt_to_S. + logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. + + ! Local variables + real, dimension(size(S)) :: Sp ! Salinity converted to [ppt] + real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S ppt-1 ~> 1] + real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from + ! practical salinity to reference salinity [nondim] + logical :: use_gsw ! If true, call gsw functions to do this conversion. + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(S) + endif + + use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS + + if (use_gsw) then + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + absSaln(is:ie) = gsw_sr_from_sp(S(is:ie)) + else + do i=is,ie ; Sp(i) = EOS%S_to_ppt * S(i) ; enddo + absSaln(is:ie) = gsw_sr_from_sp(Sp(is:ie)) + endif + + S_scale = EOS%ppt_to_S + if (present(scale)) S_scale = scale + if (S_scale /= 1.0) then ; do i=is,ie + absSaln(i) = S_scale * absSaln(i) + enddo ; endif + elseif (present(scale)) then + S_scale = Sref_Sprac * scale + do i=is,ie + absSaln(i) = S_scale * S(i) + enddo + else + do i=is,ie + absSaln(i) = Sref_Sprac * S(i) + enddo + endif + +end subroutine prac_saln_to_abs_saln + + !> Return value of EOS_quadrature logical function EOS_quadrature(EOS) type(EOS_type), intent(in) :: EOS !< Equation of state structure @@ -2161,6 +2320,12 @@ logical function EOS_unit_tests(verbose) if (verbose) write(stdout,*) '==== MOM_EOS: EOS_unit_tests ====' EOS_unit_tests = .false. ! Normally return false + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) + fail = test_TS_conversion_consistency(T_cons=9.989811727177308, S_abs=35.16504, & + T_pot=10.0, S_prac=35.0, EOS=EOS_tmp, verbose=verbose) + if (verbose .and. fail) call MOM_error(WARNING, "Some EOS variable conversions tests have failed.") + EOS_unit_tests = EOS_unit_tests .or. fail + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_UNESCO) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "UNESCO", & rho_check=1027.54345796120*EOS_tmp%kg_m3_to_R) @@ -2272,6 +2437,81 @@ logical function EOS_unit_tests(verbose) end function EOS_unit_tests +logical function test_TS_conversion_consistency(T_cons, S_abs, T_pot, S_prac, EOS, verbose) & + result(inconsistent) + real, intent(in) :: T_cons !< Conservative temperature [degC] + real, intent(in) :: S_abs !< Absolute salinity [g kg-1] + real, intent(in) :: T_pot !< Potential temperature [degC] + real, intent(in) :: S_prac !< Practical salinity [PSU] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + + ! Local variables + real :: Sabs(1) ! Absolute or reference salinity [g kg-1] + real :: Sprac(1) ! Practical salinity [PSU] + real :: Stest(1) ! A converted salinity [ppt] + real :: Tcons(1) ! Conservative temperature [degC] + real :: Tpot(1) ! Potential temperature [degC] + real :: Ttest(1) ! A converted temperature [degC] + real :: Stol ! Roundoff error on a typical value of salinities [ppt] + real :: Ttol ! Roundoff error on a typical value of temperatures [degC] + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + integer :: i, j, n + + OK = .true. + + ! Copy scalar input values into the corresponding arrays + Sabs(1) = S_abs ; Sprac(1) = S_prac ; Tcons(1) = T_cons ; Tpot(1) = T_pot + + ! Set tolerances for the conversions. + Ttol = 2.0 * 400.0*epsilon(Ttol) + Stol = 35.0 * 400.0*epsilon(Stol) + + ! Check that the converted salinities agree + call abs_saln_to_prac_saln(Sabs, Stest, EOS, use_TEOS=.true.) + test_OK = (abs(Stest(1) - Sprac(1)) <= Stol) + if (verbose) call write_check_msg("TEOS Sprac", Stest(1), Sprac(1), Stol, test_OK) + OK = OK .and. test_OK + + call abs_saln_to_prac_saln(Sabs, Stest, EOS, use_TEOS=.false.) + test_OK = (abs(Stest(1) - Sprac(1)) <= Stol) + if (verbose) call write_check_msg("MOM6 Sprac", Stest(1), Sprac(1), Stol, test_OK) + OK = OK .and. test_OK + + call prac_saln_to_abs_saln(Sprac, Stest, EOS, use_TEOS=.true.) + test_OK = (abs(Stest(1) - Sabs(1)) <= Stol) + if (verbose) call write_check_msg("TEOS Sabs", Stest(1), Sabs(1), Stol, test_OK) + OK = OK .and. test_OK + + call prac_saln_to_abs_saln(Sprac, Stest, EOS, use_TEOS=.false.) + test_OK = (abs(Stest(1) - Sabs(1)) <= Stol) + if (verbose) call write_check_msg("MOM6 Sabs", Stest(1), Sabs(1), Stol, test_OK) + OK = OK .and. test_OK + + call cons_temp_to_pot_temp(Tcons, Sabs, Ttest, EOS, use_TEOS=.true.) + test_OK = (abs(Ttest(1) - Tpot(1)) <= Ttol) + if (verbose) call write_check_msg("TEOS Tpot", Ttest(1), Tpot(1), Ttol, test_OK) + OK = OK .and. test_OK + + call cons_temp_to_pot_temp(Tcons, Sabs, Ttest, EOS, use_TEOS=.false.) + test_OK = (abs(Ttest(1) - Tpot(1)) <= Ttol) + if (verbose) call write_check_msg("MOM6 Tpot", Ttest(1), Tpot(1), Ttol, test_OK) + OK = OK .and. test_OK + + call pot_temp_to_cons_temp(Tpot, Sabs, Ttest, EOS, use_TEOS=.true.) + test_OK = (abs(Ttest(1) - Tcons(1)) <= Ttol) + if (verbose) call write_check_msg("TEOS Tcons", Ttest(1), Tcons(1), Ttol, test_OK) + OK = OK .and. test_OK + + call pot_temp_to_cons_temp(Tpot, Sabs, Ttest, EOS, use_TEOS=.false.) + test_OK = (abs(Ttest(1) - Tcons(1)) <= Ttol) + if (verbose) call write_check_msg("MOM6 Tcons", Ttest(1), Tcons(1), Ttol, test_OK) + OK = OK .and. test_OK + + inconsistent = .not.OK +end function test_TS_conversion_consistency + logical function test_TFr_consistency(S_test, p_test, EOS, verbose, EOS_name, TFr_check) & result(inconsistent) real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] @@ -2322,20 +2562,31 @@ logical function test_TFr_consistency(S_test, p_test, EOS, verbose, EOS_name, TF if (present(TFr_check)) then test_OK = (abs(TFr_check - TFr(0,0,1)) <= TFr_tol) OK = OK .and. test_OK - if (verbose) then - write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & - TFr(0,0,1), TFr_check, TFr(0,0,1)-TFr_check, TFr_tol - if (test_OK) then - call MOM_mesg(trim(EOS_name)//" TFr agrees with its check value :"//trim(mesg)) - else - call MOM_error(WARNING, trim(EOS_name)//" TFr disagrees with its check value :"//trim(mesg)) - endif - endif + if (verbose) call write_check_msg(trim(EOS_name)//" TFr", TFr(0,0,1), TFr_check, Tfr_tol, test_OK) endif inconsistent = .not.OK end function test_TFr_consistency +!> Write a message indicating how well a value matches its check value. +subroutine write_check_msg(var_name, val, val_chk, val_tol, test_OK) + character(len=*), intent(in) :: var_name !< The name of the variable being tested. + real, intent(in) :: val !< The value being checked [various] + real, intent(in) :: val_chk !< The value being checked [various] + real, intent(in) :: val_tol !< The value being checked [various] + logical, intent(in) :: test_OK !< True if the values are within their tolerance + + character(len=200) :: mesg + + write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & + val, val_chk, val-val_chk, val_tol + if (test_OK) then + call MOM_mesg(trim(var_name)//" agrees with its check value :"//trim(mesg)) + else + call MOM_error(WARNING, trim(var_name)//" disagrees with its check value :"//trim(mesg)) + endif +end subroutine write_check_msg + !> Test an equation of state for self-consistency and consistency with check values, returning false !! if it is consistent by all tests, and true if it fails any test. logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & @@ -2496,30 +2747,16 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & if (present(rho_check)) then test_OK = (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) OK = OK .and. test_OK - if (verbose) then - write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & - rho_ref+rho(0,0,0,1), rho_check, (rho_ref+rho(0,0,0,1))-rho_check, tol*rho(0,0,0,1) - if (test_OK) then - call MOM_mesg(trim(EOS_name)//" rho agrees with its check value :"//trim(mesg)) - else - call MOM_error(WARNING, trim(EOS_name)//" rho disagrees with its check value :"//trim(mesg)) - endif - endif + if (verbose) & + call write_check_msg(trim(EOS_name)//" rho", rho_ref+rho(0,0,0,1), rho_check, tol*rho(0,0,0,1), test_OK) endif ! Check that the specific volume agrees with the provided check value or the inverse of density if (present(spv_check)) then test_OK = (abs(spv_check - (spv_ref + spv(0,0,0,1))) < tol*abs(spv_ref + spv(0,0,0,1))) + if (verbose) & + call write_check_msg(trim(EOS_name)//" spv", spv_ref+spv(0,0,0,1), spv_check, tol*spv(0,0,0,1), test_OK) OK = OK .and. test_OK - if (verbose) then - write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & - spv_ref+spv(0,0,0,1), spv_check, spv_ref+spv(0,0,0,1)-spv_check, tol*spv(0,0,0,1) - if (test_OK) then - call MOM_mesg(trim(EOS_name)//" spv agrees with its check value :"//trim(mesg)) - else - call MOM_error(WARNING, trim(EOS_name)//" spv disagrees with its check value :"//trim(mesg)) - endif - endif else test_OK = (abs((rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0) < tol) OK = OK .and. test_OK @@ -2659,7 +2896,8 @@ logical function check_FD(val, val_fd, tol, verbose, field_name, order) check_FD = ( abs(val_fd(1) - val) < (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) ) - write(mesg, '(ES16.8," and ",ES16.8," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + ! write(mesg, '(ES16.8," and ",ES16.8," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & val, val_fd(1), val - val_fd(1), & 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) diff --git a/src/equation_of_state/MOM_temperature_convert.F90 b/src/equation_of_state/MOM_temperature_convert.F90 new file mode 100644 index 0000000000..ee4bc21e62 --- /dev/null +++ b/src/equation_of_state/MOM_temperature_convert.F90 @@ -0,0 +1,166 @@ +!> Functions to convert between conservative and potential temperature +module MOM_temperature_convert + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public poTemp_to_consTemp, consTemp_to_poTemp + +!>@{ Parameters in the temperature conversion code +real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from + ! reference salinity to practical salinity [nondim] +real, parameter :: I_S0 = 0.025*Sprac_Sref ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] +real, parameter :: I_cp0 = 1.0/3991.86795711963 ! The inverse of the "specific heat" for use + ! with Conservative Temperature, as defined with TEOS10 [degC kg J-1] + +! The following are coefficients of contributions to conservative temperature as a function of the square root +! of normalized absolute salinity with an offset (zS) and potential temperature (T) with a contribution +! Hab * zS**a * T**b. The numbers here are copied directly from the corresponding gsw module, but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. + +real, parameter :: H00 = 61.01362420681071*I_cp0 ! Tp to Tc fit constant [degC] +real, parameter :: H01 = 168776.46138048015*(I_cp0*I_Ts) ! Tp to Tc fit T coef. [nondim] +real, parameter :: H02 = -2735.2785605119625*(I_cp0*I_Ts**2) ! Tp to Tc fit T**2 coef. [degC-1] +real, parameter :: H03 = 2574.2164453821433*(I_cp0*I_Ts**3) ! Tp to Tc fit T**3 coef. [degC-2] +real, parameter :: H04 = -1536.6644434977543*(I_cp0*I_Ts**4) ! Tp to Tc fit T**4 coef. [degC-3] +real, parameter :: H05 = 545.7340497931629*(I_cp0*I_Ts**5) ! Tp to Tc fit T**5 coef. [degC-4] +real, parameter :: H06 = -50.91091728474331*(I_cp0*I_Ts**6) ! Tp to Tc fit T**6 coef. [degC-5] +real, parameter :: H07 = -18.30489878927802*(I_cp0*I_Ts**7) ! Tp to Tc fit T**7 coef. [degC-6] +real, parameter :: H20 = 268.5520265845071*I_cp0 ! Tp to Tc fit zS**2 coef. [degC] +real, parameter :: H21 = -12019.028203559312*(I_cp0*I_Ts) ! Tp to Tc fit zS**2 * T coef. [nondim] +real, parameter :: H22 = 3734.858026725145*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**2 * T**2 coef. [degC-1] +real, parameter :: H23 = -2046.7671145057618*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**2 * T**3 coef. [degC-2] +real, parameter :: H24 = 465.28655623826234*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**2 * T**4 coef. [degC-3] +real, parameter :: H25 = -0.6370820302376359*(I_cp0*I_Ts**5) ! Tp to Tc fit zS**2 * T**5 coef. [degC-4] +real, parameter :: H26 = -10.650848542359153*(I_cp0*I_Ts**6) ! Tp to Tc fit zS**2 * T**6 coef. [degC-5] +real, parameter :: H30 = 937.2099110620707*I_cp0 ! Tp to Tc fit zS**3 coef. [degC] +real, parameter :: H31 = 588.1802812170108*(I_cp0*I_Ts) ! Tp to Tc fit zS** 3* T coef. [nondim] +real, parameter :: H32 = 248.39476522971285*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**3 * T**2 coef. [degC-1] +real, parameter :: H33 = -3.871557904936333*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**3 * T**3 coef. [degC-2] +real, parameter :: H34 = -2.6268019854268356*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**3 * T**4 coef. [degC-3] +real, parameter :: H40 = -1687.914374187449*I_cp0 ! Tp to Tc fit zS**4 coef. [degC] +real, parameter :: H41 = 936.3206544460336*(I_cp0*I_Ts) ! Tp to Tc fit zS**4 * T coef. [nondim] +real, parameter :: H42 = -942.7827304544439*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**4 * T**2 coef. [degC-1] +real, parameter :: H43 = 369.4389437509002*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**4 * T**3 coef. [degC-2] +real, parameter :: H44 = -33.83664947895248*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**4 * T**4 coef. [degC-3] +real, parameter :: H45 = -9.987880382780322*(I_cp0*I_Ts**5) ! Tp to Tc fit zS**4 * T**5 coef. [degC-4] +real, parameter :: H50 = 246.9598888781377*I_cp0 ! Tp to Tc fit zS**5 coef. [degC] +real, parameter :: H60 = 123.59576582457964*I_cp0 ! Tp to Tc fit zS**6 coef. [degC] +real, parameter :: H70 = -48.5891069025409*I_cp0 ! Tp to Tc fit zS**7 coef. [degC] + +!>@} + +contains + +!> Convert input potential temperature [degC] and absolute salinity [g kg-1] to returned +!! conservative temperature [degC] using the polynomial expressions from TEOS-10. +elemental real function poTemp_to_consTemp(T, Sa) result(Tc) + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + ! Local variables + real :: x2 ! Absolute salinity normalized by a plausible salinity range [nondim] + real :: x ! Square root of normalized absolute salinity [nondim] + + x2 = max(I_S0 * Sa, 0.0) + x = sqrt(x2) + + Tc = H00 + (T*(H01 + T*(H02 + T*(H03 + T*(H04 + T*(H05 + T*(H06 + T* H07)))))) & + + x2*(H20 + (T*(H21 + T*(H22 + T*(H23 + T*(H24 + T*(H25 + T*H26))))) & + + x*(H30 + (T*(H31 + T*(H32 + T*(H33 + T* H34))) & + + x*(H40 + (T*(H41 + T*(H42 + T*(H43 + T*(H44 + T*H45)))) & + + x*(H50 + x*(H60 + x* H70)) )) )) )) ) + +end function poTemp_to_consTemp + + +!> Return the partial derivative of conservative temperature with potential temperature [nondim] +!! based on the polynomial expressions from TEOS-10. +elemental real function dTc_dTp(T, Sa) + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + ! Local variables + real :: x2 ! Absolute salinity normalized by a plausible salinity range [nondim] + real :: x ! Square root of normalized absolute salinity [nondim] + + x2 = max(I_S0 * Sa, 0.0) + x = sqrt(x2) + + dTc_dTp = ( H01 + T*(2.*H02 + T*(3.*H03 + T*(4.*H04 + T*(5.*H05 + T*(6.*H06 + T*(7.*H07)))))) ) & + + x2*( (H21 + T*(2.*H22 + T*(3.*H23 + T*(4.*H24 + T*(5.*H25 + T*(6.*H26)))))) & + + x*( (H31 + T*(2.*H32 + T*(3.*H33 + T*(4.*H34)))) & + + x*(H41 + T*(2.*H42 + T*(3.*H43 + T*(4.*H44 + T*(5.*H45))))) ) ) + +end function dTc_dTp + + + +!> Convert input potential temperature [degC] and absolute salinity [g kg-1] to returned +!! conservative temperature [degC] by inverting the polynomial expressions from TEOS-10. +elemental real function consTemp_to_poTemp(Tc, Sa) result(Tp) + real, intent(in) :: Tc !< Conservative temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + real :: Tp_num ! The numerator of a simple expression for potential temperature [degC] + real :: I_Tp_den ! The inverse of the denominator of a simple expression for potential temperature [nondim] + real :: Tc_diff ! The difference between an estimate of conservative temperature and its target [degC] + real :: Tp_old ! A previous estimate of the potential tempearture [degC] + real :: dTp_dTc ! The partial derivative of potential temperature with conservative temperature [nondim] + ! The following are coefficients in the nominator (TPNxx) or denominator (TPDxx) of a simple rational + ! expression that approximately converts conservative temperature to potential temperature. + real, parameter :: TPN00 = -1.446013646344788e-2 ! Simple fit numerator constant [degC] + real, parameter :: TPN10 = -3.305308995852924e-3*Sprac_Sref ! Simple fit numerator Sa coef. [degC ppt-1] + real, parameter :: TPN20 = 1.062415929128982e-4*Sprac_Sref**2 ! Simple fit numerator Sa**2 coef. [degC ppt-2] + real, parameter :: TPN01 = 9.477566673794488e-1 ! Simple fit numerator Tc coef. [nondim] + real, parameter :: TPN11 = 2.166591947736613e-3*Sprac_Sref ! Simple fit numerator Sa * Tc coef. [ppt-1] + real, parameter :: TPN02 = 3.828842955039902e-3 ! Simple fit numerator Tc**2 coef. [degC-1] + real, parameter :: TPD10 = 6.506097115635800e-4*Sprac_Sref ! Simple fit denominator Sa coef. [ppt-1] + real, parameter :: TPD01 = 3.830289486850898e-3 ! Simple fit denominator Tc coef. [degC-1] + real, parameter :: TPD02 = 1.247811760368034e-6 ! Simple fit denominator Tc**2 coef. [degC-2] + + ! Estimate the potential temperature and its derivative from an approximate rational function fit. + Tp_num = TPN00 + (Sa*(TPN10 + TPN20*Sa) + Tc*(TPN01 + (TPN11*Sa + TPN02*Tc))) + I_Tp_den = 1.0 / (1.0 + (TPD10*Sa + Tc*(TPD01 + TPD02*Tc))) + Tp = Tp_num*I_Tp_den + dTp_dTc = ((TPN01 + (TPN11*Sa + 2.*TPN02*Tc)) - (TPD01 + 2.*TPD02*Tc)*Tp)*I_Tp_den + + ! Start the 1.5 iterations through the modified Newton-Raphson iterative method, which is also known + ! as the Newton-McDougall method. In this case 1.5 iterations converge to 64-bit machine precision + ! for oceanographically relevant temperatures and salinities. + + Tc_diff = poTemp_to_consTemp(Tp, Sa) - Tc + Tp_old = Tp + Tp = Tp_old - Tc_diff*dTp_dTc + + dTp_dTc = 1.0 / dTc_dTp(0.5*(Tp + Tp_old), Sa) + + Tp = Tp_old - Tc_diff*dTp_dTc + Tc_diff = poTemp_to_consTemp(Tp, Sa) - Tc + Tp_old = Tp + + Tp = Tp_old - Tc_diff*dTp_dTc + +end function consTemp_to_poTemp + +!> \namespace MOM_temperature_conv +!! +!! \section MOM_temperature_conv Temperature conversions +!! +!! This module has functions that convert potential temperature to conservative temperature +!! and the reverse, as described in the TEOS-10 manual. This code was originally derived +!! from their corresponding routines in the gsw code package, but has had some refactoring so that the +!! answers are more likely to reproduce across compilers and levels of optimization. A complete +!! discussion of the thermodynamics of seawater and the definition of conservative temperature +!! can be found in IOC et al. (2010). +!! +!! \subsection section_temperature_conv_references References +!! +!! IOC, SCOR and IAPSO, 2010: The international thermodynamic equation of seawater - 2010: +!! Calculation and use of thermodynamic properties. Intergovernmental Oceanographic Commission, +!! Manuals and Guides No. 56, UNESCO (English), 196 pp. +!! (Available from www.teos-10.org/pubs/TEOS-10_Manual.pdf) + +end module MOM_temperature_convert From b832f2ceb6758c3199cf334bab613ceff30db4d0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Mar 2023 07:22:03 -0400 Subject: [PATCH 65/91] Update _Equation_of_State.dox Updated _Equation_of_State.dox to reflect the new options for the equation of state and freezing point calculations. --- src/equation_of_state/_Equation_of_State.dox | 86 +++++++++++++++----- 1 file changed, 66 insertions(+), 20 deletions(-) diff --git a/src/equation_of_state/_Equation_of_State.dox b/src/equation_of_state/_Equation_of_State.dox index 791c7001b1..0e80c9652a 100644 --- a/src/equation_of_state/_Equation_of_State.dox +++ b/src/equation_of_state/_Equation_of_State.dox @@ -2,9 +2,10 @@ Within MOM6, there is a wrapper for the equation of state, so that all calls look the same from the rest of the model. The equation of state code has to calculate -not just in situ density, but also the compressibility and various derivatives of -the density. There is also code for computing specific volume and the -freezing temperature. +not just in situ or potential density, but also the compressibility and various +derivatives of the density. There is also code for computing specific volume and the +freezing temperature, and for converting between potential and conservative +temperatures and between practical and reference (or absolute) salinity. \section Linear_EOS Linear Equation of State @@ -12,51 +13,96 @@ Compute the required quantities with uniform values for \f$\alpha = \frac{\parti \rho}{\partial T}\f$ and \f$\beta = \frac{\partial \rho}{\partial S}\f$, (DRHO_DT, DRHO_DS in MOM_input, also uses RHO_T0_S0). -\section Wright_EOS Wright Equation of State +\section Wright_EOS Wright reduced range Equation of State -Compute the required quantities using the equation of state from \cite wright1997. -This equation of state is in the form: +Compute the required quantities using the equation of state from \cite wright1997 +as a function of potential temperature and practical salinity, with +coefficients based on the reduced-range (salinity from 28 to 38 PSU, temperature +from -2 to 30 degC and pressure up to 5000 dbar) fit to the UNESCO 1981 data. This +equation of state is in the form: \f[ \alpha(s, \theta, p) = A(s, \theta) + \frac{\lambda(s, \theta)}{P(s, \theta) + p} \f] where \f$A, \lambda\f$ and \f$P\f$ are functions only of \f$s\f$ and \f$\theta\f$ and \f$\alpha = 1/ \rho\f$ is the specific volume. This form is useful for the -pressure gradient computation as discussed in \ref section_PG. +pressure gradient computation as discussed in \ref section_PG. This EoS is selected +by setting EQN_OF_STATE = WRIGHT or WRIGHT_RED, which are mathematically equivalent, +but the latter is refactored for consistent answers between compiler settings. + +\section Wright_full_EOS Wright full range Equation of State + +Compute the required quantities using the equation of state from \cite wright1997 +as a function of potential temperature and practical salinity, with +coefficients based on a fit to the UNESCO 1981 data over the full range of +validity of that data (salinity from 0 to 40 PSU, temperatures from -2 to 40 +degC, and pressures up to 10000 dbar). The functional form of the WRIGHT_FULL +equation of state is the same as for WRIGHT or WRIGHT_RED, but with different +coefficients. + +\section Jackett06_EOS Jackett et al. (2006) Equation of State + +Compute the required quantities using the equation of state from Jackett et al. +(2006) as a function of potential temperature and practical salinity, with +coefficients based on a fit to the updated data that were later used to define +the TEOS-10 equation of state over the full range of validity of that data +(salinity from 0 to 42 PSU, temperatures from the freezing point to 40 degC, and +pressures up to 8500 dbar), but focused on the "oceanographic funnel" of +thermodynamic properties observed in the ocean. This equation of state is +commonly used in realistic Hycom simulations. -\section NEMO_EOS NEMO Equation of State +\section UNESCO_EOS UNESCO Equation of State -Compute the required quantities using the equation of state from \cite roquet2015. +Compute the required quantities using the equation of state from \cite jackett1995, +which uses potential temperature and practical salinity as state variables and is +a fit to the 1981 UNESCO equation of state with the same functional form but a +replacement of the temperature variable (the original uses in situ temperature). -\section UNESCO_EOS UNESCO Equation of State +\section ROQUET_RHO_EOS ROQUET_RHO Equation of State + +Compute the required quantities using the equation of state from \cite roquet2015, +which uses a 75-member polynomial for density as a function of conservative temperature +and absolute salinity, in a fit to the output from the full TEOS-10 equation of state. -Compute the required quantities using the equation of state from \cite jackett1995. +\section ROQUET_SPV_EOS ROQUET_SPV Equation of State + +Compute the required quantities using the specific volume oriented equation of state from +\cite roquet2015, which uses a 75-member polynomial for specific volume as a function of +conservative temperature and absolute salinity, in a fit to the output from the full +TEOS-10 equation of state. \section TEOS-10_EOS TEOS-10 Equation of State Compute the required quantities using the equation of state from -[TEOS-10](http://www.teos-10.org/). +[TEOS-10](http://www.teos-10.org/), with calls directly to the subroutines +in that code package. \section section_TFREEZE Freezing Temperature of Sea Water -There are three choices for computing the freezing point of sea water: +There are four choices for computing the freezing point of sea water: \li Linear The freezing temperature is a linear function of the salinity and pressure: \f[ T_{Fr} = (T_{Fr0} + a\,S) + b\,P \f] -where \f$T_{Fr0},a,b\f$ are contants which can be set in MOM_input (TFREEZE_S0_P0, +where \f$T_{Fr0},a,b\f$ are constants which can be set in MOM_input (TFREEZE_S0_P0, DTFREEZE_DS, DTFREEZE_DP). -\li Millero The \cite millero1978 equation is used, but modified so that it is a function -of potential temperature rather than in situ temperature: +\li Millero The \cite millero1978 equation is used to calculate the freezing +point from practical salinity and pressure, but modified so that returns a +potential temperature rather than an in situ temperature: \f[ T_{Fr} = S(a + (b \sqrt{\max(S,0.0)} + c\, S)) + d\,P \f] -where \f$a,b, c, d\f$ are fixed contants. +where \f$a,b, c, d\f$ are fixed constants. + +\li TEOS-10 The TEOS-10 package is used to compute the freezing conservative +temperature [degC] from absolute salinity [g/kg], and pressure [Pa]. This one or +TEOS_poly must be used if you are using the ROQUET_RHO, ROQUET_SPV or TEOS-10 +equation of state. -\li TEOS-10 The TEOS-10 package is used to compute the freezing conservative temperature -[degC] from absolute salinity [g/kg], and pressure [Pa]. This one must be used -if you are using the NEMO or TEOS-10 equation of state. +\li TEOS_poly A 23-term polynomial fit refactored from the TEOS-10 package is +used to compute the freezing conservative temperature [degC] from absolute +salinity [g/kg], and pressure [Pa]. */ From 433ac309790691e7993ac0805dc74b0ca40e2082 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Mar 2023 18:21:11 -0400 Subject: [PATCH 66/91] +Eliminate use_TEOS arg to cons_temp_to_pot_temp Eliminate use_TEOS optional arguments that were recently added to cons_temp_to_pot_temp and 4 other thermodynamic variable conversion functions, along with calls to gsw_pt_to_ct and similar conversion functions. All answers in the MOM6-examples test suite are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 138 +++++------------------------- 1 file changed, 22 insertions(+), 116 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 04b5e74c94..f056915fa0 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -46,7 +46,7 @@ module MOM_EOS use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10, calculate_specvol_derivs_teos10 use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10, calculate_compress_teos10 use MOM_EOS_TEOS10, only : EoS_fit_range_TEOS10 -! use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_temperature_convert, only : poTemp_to_consTemp, consTemp_to_poTemp use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero use MOM_TFreeze, only : calculate_TFreeze_teos10, calculate_TFreeze_TEOS_poly @@ -56,8 +56,6 @@ module MOM_EOS use MOM_io, only : stdout use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct -use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt implicit none ; private @@ -1991,7 +1989,7 @@ end subroutine EOS_use_linear !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 -subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS, use_TEOS) +subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) integer, intent(in) :: kd !< The number of layers to work on type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & @@ -2001,11 +1999,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS, use_TEOS) real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & intent(in) :: mask_z !< 3d mask regulating which points to convert [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure - logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. - real :: gsw_sr_from_sp ! Reference salinity after conversion from practical salinity [ppt] - real :: gsw_ct_from_pt ! Conservative temperature after conversion from potential temperature [degC] - logical :: use_gsw ! If true, call gsw functions to do this conversion. real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from ! practical salinity to reference salinity [nondim] integer :: i, j, k @@ -2013,30 +2007,19 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS, use_TEOS) if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_ROQUET_RHO) .and. & (EOS%form_of_EOS /= EOS_ROQUET_SPV)) return - use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS - - if (use_gsw) then - do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - if (mask_z(i,j,k) >= 1.0) then - S(i,j,k) = EOS%ppt_to_S*gsw_sr_from_sp(EOS%S_to_ppt*S(i,j,k)) - T(i,j,k) = EOS%degC_to_C*gsw_ct_from_pt(EOS%S_to_ppt*S(i,j,k), EOS%S_to_ppt*T(i,j,k)) - endif - enddo ; enddo ; enddo - else - do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - if (mask_z(i,j,k) >= 1.0) then - S(i,j,k) = Sref_Sprac * S(i,j,k) - T(i,j,k) = EOS%degC_to_C*poTemp_to_consTemp(EOS%S_to_ppt*S(i,j,k), EOS%S_to_ppt*T(i,j,k)) - endif - enddo ; enddo ; enddo - endif + do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + if (mask_z(i,j,k) >= 1.0) then + S(i,j,k) = Sref_Sprac * S(i,j,k) + T(i,j,k) = EOS%degC_to_C*poTemp_to_consTemp(EOS%S_to_ppt*S(i,j,k), EOS%S_to_ppt*T(i,j,k)) + endif + enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 !> Converts an array of conservative temperatures to potential temperatures. The input arguments !! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. -subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale, use_TEOS) +subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) real, dimension(:), intent(in) :: T !< Conservative temperature [C ~> degC] real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] real, dimension(:), intent(inout) :: poTemp !< The potential temperature with a reference pressure @@ -2048,13 +2031,11 @@ subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale, use_TEOS) !! potential temperature in place of with scaling stored !! in EOS. A value of 1.0 returns temperatures in [degC], !! while the default is equivalent to EOS%degC_to_C. - logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. ! Local variables real, dimension(size(T)) :: Ta ! Temperature converted to [degC] real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] - logical :: use_gsw ! If true, call gsw functions to do this conversion. integer :: i, is, ie if (present(dom)) then @@ -2063,24 +2044,14 @@ subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale, use_TEOS) is = 1 ; ie = size(T) endif - use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS - if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then - if (use_gsw) then - poTemp(is:ie) = gsw_pt_from_ct(S(is:ie), T(is:ie)) - else - poTemp(is:ie) = consTemp_to_poTemp(T(is:ie), S(is:ie)) - endif + poTemp(is:ie) = consTemp_to_poTemp(T(is:ie), S(is:ie)) else do i=is,ie Ta(i) = EOS%C_to_degC * T(i) Sa(i) = EOS%S_to_ppt * S(i) enddo - if (use_gsw) then - poTemp(is:ie) = gsw_pt_from_ct(Sa(is:ie), Ta(is:ie)) - else - poTemp(is:ie) = consTemp_to_poTemp(Ta(is:ie), Sa(is:ie)) - endif + poTemp(is:ie) = consTemp_to_poTemp(Ta(is:ie), Sa(is:ie)) endif T_scale = EOS%degC_to_C @@ -2095,7 +2066,7 @@ end subroutine cons_temp_to_pot_temp !> Converts an array of potential temperatures to conservative temperatures. The input arguments !! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. -subroutine pot_temp_to_cons_temp(T, S, consTemp, EOS, dom, scale, use_TEOS) +subroutine pot_temp_to_cons_temp(T, S, consTemp, EOS, dom, scale) real, dimension(:), intent(in) :: T !< Potential temperature [C ~> degC] real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] real, dimension(:), intent(inout) :: consTemp !< The conservative temperature [C ~> degC] @@ -2106,13 +2077,11 @@ subroutine pot_temp_to_cons_temp(T, S, consTemp, EOS, dom, scale, use_TEOS) !! potential temperature in place of with scaling stored !! in EOS. A value of 1.0 returns temperatures in [degC], !! while the default is equivalent to EOS%degC_to_C. - logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. ! Local variables real, dimension(size(T)) :: Tp ! Potential temperature converted to [degC] real, dimension(size(S)) :: Sa ! Absolute salinity converted to [ppt] real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] - logical :: use_gsw ! If true, call gsw functions to do this conversion. integer :: i, is, ie if (present(dom)) then @@ -2121,24 +2090,15 @@ subroutine pot_temp_to_cons_temp(T, S, consTemp, EOS, dom, scale, use_TEOS) is = 1 ; ie = size(T) endif - use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then - if (use_gsw) then - consTemp(is:ie) = gsw_ct_from_pt(S(is:ie), T(is:ie)) - else - consTemp(is:ie) = poTemp_to_consTemp(T(is:ie), S(is:ie)) - endif + consTemp(is:ie) = poTemp_to_consTemp(T(is:ie), S(is:ie)) else do i=is,ie Tp(i) = EOS%C_to_degC * T(i) Sa(i) = EOS%S_to_ppt * S(i) enddo - if (use_gsw) then - consTemp(is:ie) = gsw_ct_from_pt(Sa(is:ie), Tp(is:ie)) - else - consTemp(is:ie) = poTemp_to_consTemp(Tp(is:ie), Sa(is:ie)) - endif + consTemp(is:ie) = poTemp_to_consTemp(Tp(is:ie), Sa(is:ie)) endif T_scale = EOS%degC_to_C @@ -2153,7 +2113,7 @@ end subroutine pot_temp_to_cons_temp !> Converts an array of absolute salinity to practical salinity. The input arguments !! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. -subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale, use_TEOS) +subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] real, dimension(:), intent(inout) :: prSaln !< Practical salinity [S ~> ppt] type(EOS_type), intent(in) :: EOS !< Equation of state structure @@ -2163,14 +2123,12 @@ subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale, use_TEOS) !! practical in place of with scaling stored !! in EOS. A value of 1.0 returns salinities in [PSU], !! while the default is equivalent to EOS%ppt_to_S. - logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. ! Local variables real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S ppt-1 ~> 1] real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from ! reference salinity to practical salinity [nondim] - logical :: use_gsw ! If true, call gsw functions to do this conversion. integer :: i, is, ie if (present(dom)) then @@ -2179,22 +2137,7 @@ subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale, use_TEOS) is = 1 ; ie = size(S) endif - use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS - - if (use_gsw) then - if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then - prSaln(is:ie) = gsw_sp_from_sr(S(is:ie)) - else - do i=is,ie ; Sa(i) = EOS%S_to_ppt * S(i) ; enddo - prSaln(is:ie) = gsw_sp_from_sr(Sa(is:ie)) - endif - - S_scale = EOS%ppt_to_S - if (present(scale)) S_scale = scale - if (S_scale /= 1.0) then ; do i=is,ie - prSaln(i) = S_scale * prSaln(i) - enddo ; endif - elseif (present(scale)) then + if (present(scale)) then S_scale = Sprac_Sref * scale do i=is,ie prSaln(i) = S_scale * S(i) @@ -2211,7 +2154,7 @@ end subroutine abs_saln_to_prac_saln !> Converts an array of absolute salinity to practical salinity. The input arguments !! use the dimensionally rescaling as specified within the EOS type. The output potential !! temperature uses this same scaling, but this can be replaced by the factor given by scale. -subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale, use_TEOS) +subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale) real, dimension(:), intent(in) :: S !< Practical salinity [S ~> ppt] real, dimension(:), intent(inout) :: absSaln !< Absolute salinity [S ~> ppt] type(EOS_type), intent(in) :: EOS !< Equation of state structure @@ -2221,14 +2164,12 @@ subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale, use_TEOS) !! practical in place of with scaling stored !! in EOS. A value of 1.0 returns salinities in [PSU], !! while the default is equivalent to EOS%ppt_to_S. - logical, optional, intent(in) :: use_TEOS !< If present and true, call the TEOS code to do the conversion. ! Local variables real, dimension(size(S)) :: Sp ! Salinity converted to [ppt] real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S ppt-1 ~> 1] real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from ! practical salinity to reference salinity [nondim] - logical :: use_gsw ! If true, call gsw functions to do this conversion. integer :: i, is, ie if (present(dom)) then @@ -2237,22 +2178,7 @@ subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale, use_TEOS) is = 1 ; ie = size(S) endif - use_gsw = .false. ; if (present(use_TEOS)) use_gsw = use_TEOS - - if (use_gsw) then - if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then - absSaln(is:ie) = gsw_sr_from_sp(S(is:ie)) - else - do i=is,ie ; Sp(i) = EOS%S_to_ppt * S(i) ; enddo - absSaln(is:ie) = gsw_sr_from_sp(Sp(is:ie)) - endif - - S_scale = EOS%ppt_to_S - if (present(scale)) S_scale = scale - if (S_scale /= 1.0) then ; do i=is,ie - absSaln(i) = S_scale * absSaln(i) - enddo ; endif - elseif (present(scale)) then + if (present(scale)) then S_scale = Sref_Sprac * scale do i=is,ie absSaln(i) = S_scale * S(i) @@ -2469,42 +2395,22 @@ logical function test_TS_conversion_consistency(T_cons, S_abs, T_pot, S_prac, EO Stol = 35.0 * 400.0*epsilon(Stol) ! Check that the converted salinities agree - call abs_saln_to_prac_saln(Sabs, Stest, EOS, use_TEOS=.true.) - test_OK = (abs(Stest(1) - Sprac(1)) <= Stol) - if (verbose) call write_check_msg("TEOS Sprac", Stest(1), Sprac(1), Stol, test_OK) - OK = OK .and. test_OK - - call abs_saln_to_prac_saln(Sabs, Stest, EOS, use_TEOS=.false.) + call abs_saln_to_prac_saln(Sabs, Stest, EOS) test_OK = (abs(Stest(1) - Sprac(1)) <= Stol) if (verbose) call write_check_msg("MOM6 Sprac", Stest(1), Sprac(1), Stol, test_OK) OK = OK .and. test_OK - call prac_saln_to_abs_saln(Sprac, Stest, EOS, use_TEOS=.true.) - test_OK = (abs(Stest(1) - Sabs(1)) <= Stol) - if (verbose) call write_check_msg("TEOS Sabs", Stest(1), Sabs(1), Stol, test_OK) - OK = OK .and. test_OK - - call prac_saln_to_abs_saln(Sprac, Stest, EOS, use_TEOS=.false.) + call prac_saln_to_abs_saln(Sprac, Stest, EOS) test_OK = (abs(Stest(1) - Sabs(1)) <= Stol) if (verbose) call write_check_msg("MOM6 Sabs", Stest(1), Sabs(1), Stol, test_OK) OK = OK .and. test_OK - call cons_temp_to_pot_temp(Tcons, Sabs, Ttest, EOS, use_TEOS=.true.) - test_OK = (abs(Ttest(1) - Tpot(1)) <= Ttol) - if (verbose) call write_check_msg("TEOS Tpot", Ttest(1), Tpot(1), Ttol, test_OK) - OK = OK .and. test_OK - - call cons_temp_to_pot_temp(Tcons, Sabs, Ttest, EOS, use_TEOS=.false.) + call cons_temp_to_pot_temp(Tcons, Sabs, Ttest, EOS) test_OK = (abs(Ttest(1) - Tpot(1)) <= Ttol) if (verbose) call write_check_msg("MOM6 Tpot", Ttest(1), Tpot(1), Ttol, test_OK) OK = OK .and. test_OK - call pot_temp_to_cons_temp(Tpot, Sabs, Ttest, EOS, use_TEOS=.true.) - test_OK = (abs(Ttest(1) - Tcons(1)) <= Ttol) - if (verbose) call write_check_msg("TEOS Tcons", Ttest(1), Tcons(1), Ttol, test_OK) - OK = OK .and. test_OK - - call pot_temp_to_cons_temp(Tpot, Sabs, Ttest, EOS, use_TEOS=.false.) + call pot_temp_to_cons_temp(Tpot, Sabs, Ttest, EOS) test_OK = (abs(Ttest(1) - Tcons(1)) <= Ttol) if (verbose) call write_check_msg("MOM6 Tcons", Ttest(1), Tcons(1), Ttol, test_OK) OK = OK .and. test_OK From ed58758d0467d355c46b798823283515e2e230fb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 23 Mar 2023 14:09:32 -0400 Subject: [PATCH 67/91] +Make calculate_density_array private Removed calculate_density_array from the overloaded public calculate_density interface, and similarly for the other EOS calculate_..._array routines, to help standardize how they are called. Calculate_density_derivs_array is the one exception is because it is being called from SIS2 and has to stay publicly visible for now. Additionally, the scalar and 1-d versions of the calculate_stanley_density routines were refactored to just use calculate_density and calculate_density_second_derivs call and avoid any EoS-specific logic, while the unused routine calculate_stanley_density_array is eliminated altogether. All answers are bitwise identical, including in extra tests that use the stanley_density routines. --- src/equation_of_state/MOM_EOS.F90 | 243 +++--------------------------- 1 file changed, 20 insertions(+), 223 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index f056915fa0..2f2dbb6eb3 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -91,16 +91,14 @@ module MOM_EOS !> Calculates density of sea water from T, S and P interface calculate_density module procedure calculate_density_scalar - module procedure calculate_density_array module procedure calculate_density_1d module procedure calculate_stanley_density_scalar - module procedure calculate_stanley_density_array module procedure calculate_stanley_density_1d end interface calculate_density !> Calculates specific volume of sea water from T, S and P interface calculate_spec_vol - module procedure calc_spec_vol_scalar, calculate_spec_vol_array + module procedure calc_spec_vol_scalar module procedure calc_spec_vol_1d end interface calculate_spec_vol @@ -112,7 +110,7 @@ module MOM_EOS !> Calculate the derivatives of specific volume with temperature and salinity from T, S, and P interface calculate_specific_vol_derivs - module procedure calc_spec_vol_derivs_1d, calculate_spec_vol_derivs_array + module procedure calc_spec_vol_derivs_1d end interface calculate_specific_vol_derivs !> Calculates the second derivatives of density with various combinations of temperature, @@ -262,60 +260,17 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in !! combination with scaling stored in EOS [various] ! Local variables - real :: d2RdTT ! Second derivative of density with temperature [kg m-3 degC-2] - real :: d2RdST ! Second derivative of density with temperature and salinity [kg m-3 degC-1 ppt-1] - real :: d2RdSS ! Second derivative of density with salinity [kg m-3 ppt-2] - real :: d2RdSp ! Second derivative of density with salinity and pressure [kg m-3 ppt-1 Pa-1] - real :: d2RdTp ! Second derivative of density with temperature and pressure [kg m-3 degC-1 Pa-1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: T_scale ! A factor to convert temperature to units of degC [degC C-1 ~> 1] - real :: S_scale ! A factor to convert salinity to units of ppt [ppt S-1 ~> 1] + real :: d2RdTT ! Second derivative of density with temperature [R C-2 ~> kg m-3 degC-2] + real :: d2RdST ! Second derivative of density with temperature and salinity [R S-1 C-1 ~> kg m-3 degC-1 ppt-1] + real :: d2RdSS ! Second derivative of density with salinity [R S-2 ~> kg m-3 ppt-2] + real :: d2RdSp ! Second derivative of density with salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: d2RdTp ! Second derivative of density with temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] call calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) - - p_scale = EOS%RL2_T2_to_Pa - T_scale = EOS%C_to_degC - S_scale = EOS%S_to_ppt - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_WRIGHT) - if (EOS%use_Wright_2nd_deriv_bug) then - call calc_density_second_derivs_wright_buggy(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - else - call calculate_density_second_derivs_wright(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - endif - case (EOS_WRIGHT_FULL) - call calculate_density_second_derivs_wright_full(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_WRIGHT_RED) - call calculate_density_second_derivs_wright_red(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_UNESCO) - call calculate_density_second_derivs_UNESCO(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_ROQUET_RHO) - call calculate_density_second_derivs_Roquet_rho(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_ROQUET_SPV) - call calculate_density_second_derivs_Roquet_SpV(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case (EOS_JACKETT06) - call calculate_density_second_derivs_Jackett06(T_scale*T, S_scale*S, p_scale*pressure, & - d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP) - case default - call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") - end select + call calculate_density_second_derivs_scalar(T, S, pressure, d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP, EOS) ! Equation 25 of Stanley et al., 2020. - rho = rho + EOS%kg_m3_to_R * ( 0.5 * (T_scale**2 * d2RdTT) * Tvar + & - ( (S_scale*T_scale * d2RdST) * TScov + 0.5 * (S_scale**2 * d2RdSS) * Svar ) ) + rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) if (present(scale)) rho = rho * scale @@ -367,93 +322,6 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end subroutine calculate_density_array -!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs -!! including the variance of T, S and covariance of T-S. -!! The calculation uses only the second order correction in a series as discussed -!! in Stanley et al., 2020. -!! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rho, start, npts, EOS, rho_ref, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] - real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] - real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] - real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] - integer, intent(in) :: start !< Start index for computation - integer, intent(in) :: npts !< Number of point to compute - type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output - !! density, perhaps to other units than kg m-3 [various] - ! Local variables - real, dimension(size(T)) :: & - d2RdTT, & ! Second derivative of density with temperature [kg m-3 degC-2] - d2RdST, & ! Second derivative of density with temperature and salinity [kg m-3 degC-1 ppt-1] - d2RdSS, & ! Second derivative of density with salinity [kg m-3 ppt-2] - d2RdSp, & ! Second derivative of density with salinity and pressure [kg m-3 ppt-1 Pa-1] - d2RdTp ! Second derivative of density with temperature and pressure [kg m-3 degC-1 Pa-1] - integer :: j - - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) - if (EOS%use_Wright_2nd_deriv_bug) then - call calc_density_second_derivs_wright_buggy(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - else - call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - endif - case (EOS_WRIGHT_FULL) - call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_wright_full(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_WRIGHT_RED) - call calculate_density_wright_red(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_wright_red(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_UNESCO) - call calculate_density_UNESCO(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_UNESCO(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_ROQUET_RHO) - call calculate_density_Roquet_rho(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_Roquet_rho(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_ROQUET_SPV) - call calculate_density_Roquet_SpV(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_Roquet_SpV(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_JACKETT06) - call calculate_density_Jackett06(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_Jackett06(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case default - call MOM_error(FATAL, "calculate_stanley_density_array: EOS%form_of_EOS is not valid.") - end select - - ! Equation 25 of Stanley et al., 2020. - do j=start,start+npts-1 - rho(j) = rho(j) & - + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) - enddo - - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - rho(j) = scale * rho(j) - enddo ; endif ; endif - -end subroutine calculate_stanley_density_array - !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs, !! potentially limiting the domain of indices that are worked on. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. @@ -526,21 +394,12 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling stored in EOS [various] ! Local variables - real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: T2_scale ! A factor to convert temperature variance to units of degC2 [degC2 C-2 ~> 1] - real :: S2_scale ! A factor to convert salinity variance to units of ppt2 [ppt2 S-2 ~> 1] - real :: TS_scale ! A factor to convert temperature-salinity covariance to units of - ! degC ppt [degC ppt C-1 S-1 ~> 1] - real :: rho_reference ! rho_ref converted to [kg m-3] - real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] - real, dimension(size(rho)) :: Ta ! Temperature converted to [degC] - real, dimension(size(rho)) :: Sa ! Salinity converted to [ppt] real, dimension(size(T)) :: & - d2RdTT, & ! Second derivative of density with temperature [kg m-3 degC-2] - d2RdST, & ! Second derivative of density with temperature and salinity [kg m-3 degC-1 ppt-1] - d2RdSS, & ! Second derivative of density with salinity [kg m-3 ppt-2] - d2RdSp, & ! Second derivative of density with salinity and pressure [kg m-3 ppt-1 Pa-1] - d2RdTp ! Second derivative of density with temperature and pressure [kg m-3 degC-1 Pa-1] + d2RdTT, & ! Second derivative of density with temperature [R C-2 ~> kg m-3 degC-2] + d2RdST, & ! Second derivative of density with temperature and salinity [R S-1 C-1 ~> kg m-3 degC-1 ppt-1] + d2RdSS, & ! Second derivative of density with salinity [R S-2 ~> kg m-3 ppt-2] + d2RdSp, & ! Second derivative of density with salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + d2RdTp ! Second derivative of density with temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] integer :: i, is, ie, npts if (present(dom)) then @@ -549,79 +408,17 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, is = 1 ; ie = size(rho) ; npts = 1 + ie - is endif - do i=is,ie - pres(i) = EOS%RL2_T2_to_Pa * pressure(i) - Ta(i) = EOS%C_to_degC * T(i) - Sa(i) = EOS%S_to_ppt * S(i) - enddo - T2_scale = EOS%C_to_degC**2 - S2_scale = EOS%S_to_ppt**2 - TS_scale = EOS%C_to_degC*EOS%S_to_ppt - - ! Rho_ref is seems like it is always present when calculate_Stanley_density is called, so - ! always set rho_reference, even though a 0 value can change answers at roundoff with - ! some equations of state. - rho_reference = 0.0 ; if (present(rho_ref)) rho_reference = EOS%R_to_kg_m3*rho_ref - - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(Ta, Sa, pres, rho, is, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_reference) - call calculate_density_second_derivs_linear(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_WRIGHT) - call calculate_density_wright(Ta, Sa, pres, rho, is, npts, rho_reference) - if (EOS%use_Wright_2nd_deriv_bug) then - call calc_density_second_derivs_wright_buggy(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - else - call calculate_density_second_derivs_wright(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - endif - case (EOS_WRIGHT_FULL) - call calculate_density_wright_full(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_wright_full(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_WRIGHT_RED) - call calculate_density_wright_red(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_wright_red(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_UNESCO) - call calculate_density_UNESCO(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_UNESCO(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_ROQUET_RHO) - call calculate_density_Roquet_rho(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_Roquet_rho(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_ROQUET_SPV) - call calculate_density_Roquet_SpV(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_Roquet_SpV(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_TEOS10) - call calculate_density_teos10(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_teos10(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case (EOS_JACKETT06) - call calculate_density_Jackett06(Ta, Sa, pres, rho, is, npts, rho_reference) - call calculate_density_second_derivs_Jackett06(Ta, Sa, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, is, npts) - case default - call MOM_error(FATAL, "calculate_stanley_density_1d: EOS is not valid.") - end select + call calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref) + call calculate_density_second_derivs_1d(T, S, pressure, d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP, EOS, dom) ! Equation 25 of Stanley et al., 2020. do i=is,ie - rho(i) = rho(i) + ( 0.5 * (T2_scale * d2RdTT(i)) * Tvar(i) + & - ( (TS_scale * d2RdST(i)) * TScov(i) + & - 0.5 * (S2_scale * d2RdSS(i)) * Svar(i) ) ) + rho(i) = rho(i) + ( 0.5 * d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + 0.5 * d2RdSS(i) * Svar(i) ) ) enddo - rho_scale = EOS%kg_m3_to_R - if (present(scale)) rho_scale = rho_scale * scale - if (rho_scale /= 1.0) then ; do i=is,ie - rho(i) = rho_scale * rho(i) - enddo ; endif + if (present(scale)) then ; if (scale /= 1.0) then ; do i=is,ie + rho(i) = scale * rho(i) + enddo ; endif ; endif end subroutine calculate_stanley_density_1d From ded1382bc7410d2b6f500272aa77b719ea6810ee Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 22 Apr 2023 14:02:58 -0400 Subject: [PATCH 68/91] +Rename WRIGHT_RED to WRIGHT_REDUCED Revised the setting EQN_OF_STATE to select the Wright equation of state with the reduced-range fit to "WRIGHT_REDUCED" (instead of "WRIGHT_RED") for greater clarity, in response to a comment in the review of the pull request with this sequence of code revisions. All answers are bitwise identical, but this changes the text for a recently added input parameter and it leads to changes in some comments in the MOM_parameter_doc files. --- src/equation_of_state/MOM_EOS.F90 | 50 +++++++++++++++---------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 2f2dbb6eb3..276c4c3019 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -174,9 +174,9 @@ module MOM_EOS integer, parameter, public :: EOS_UNESCO = 2 !< A named integer specifying an equation of state integer, parameter, public :: EOS_WRIGHT = 3 !< A named integer specifying an equation of state integer, parameter, public :: EOS_WRIGHT_FULL = 4 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_WRIGHT_RED = 5 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT_REDUCED = 5 !< A named integer specifying an equation of state integer, parameter, public :: EOS_TEOS10 = 6 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_ROQUET_RHO = 7 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_ROQUET_RHO = 7 !< A named integer specifying an equation of state integer, parameter, public :: EOS_ROQUET_SPV = 8 !< A named integer specifying an equation of state integer, parameter, public :: EOS_JACKETT06 = 9 !< A named integer specifying an equation of state @@ -184,7 +184,7 @@ module MOM_EOS character*(12), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state character*(12), parameter :: EOS_JACKETT_STRING = "JACKETT_MCD" !< A string for specifying the equation of state character*(12), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state -character*(12), parameter :: EOS_WRIGHT_RED_STRING = "WRIGHT_RED" !< A string for specifying the equation of state +character*(16), parameter :: EOS_WRIGHT_RED_STRING = "WRIGHT_REDUCED" !< A string for specifying the equation of state character*(12), parameter :: EOS_WRIGHT_FULL_STRING = "WRIGHT_FULL" !< A string for specifying the equation of state character*(12), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state character*(12), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state @@ -302,7 +302,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) case (EOS_WRIGHT_FULL) call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_density_wright_red(T, S, pressure, rho, start, npts, rho_ref) case (EOS_TEOS10) call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) @@ -449,7 +449,7 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s call calculate_spec_vol_wright(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_WRIGHT_FULL) call calculate_spec_vol_wright_full(T, S, pressure, specvol, start, npts, spv_ref) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_spec_vol_wright_red(T, S, pressure, specvol, start, npts, spv_ref) case (EOS_TEOS10) call calculate_spec_vol_teos10(T, S, pressure, specvol, start, npts, spv_ref) @@ -754,7 +754,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_WRIGHT_FULL) call calculate_density_derivs_wright_full(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_density_derivs_wright_red(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_TEOS10) call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) @@ -865,7 +865,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS call calculate_density_derivs_wright(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) case (EOS_WRIGHT_FULL) call calculate_density_derivs_wright_full(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_density_derivs_wright_red(Ta(1), Sa(1), pres(1),drho_dT, drho_dS) case (EOS_TEOS10) call calculate_density_derivs_teos10(Ta(1), Sa(1), pres(1), drho_dT, drho_dS) @@ -938,7 +938,7 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_density_second_derivs_wright_red(T, S, pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_UNESCO) @@ -980,7 +980,7 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_density_second_derivs_wright_red(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) case (EOS_UNESCO) @@ -1076,7 +1076,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr case (EOS_WRIGHT_FULL) call calculate_density_second_derivs_wright_full(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_density_second_derivs_wright_red(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_UNESCO) @@ -1156,7 +1156,7 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_WRIGHT_FULL) call calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_specvol_derivs_wright_red(T, S, pressure, dSV_dT, dSV_dS, start, npts) case (EOS_TEOS10) call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) @@ -1273,7 +1273,7 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) call calculate_compress_wright(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_WRIGHT_FULL) call calculate_compress_wright_full(Ta, Sa, pres, rho, drho_dp, is, npts) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call calculate_compress_wright_red(Ta, Sa, pres, rho, drho_dp, is, npts) case (EOS_TEOS10) call calculate_compress_teos10(Ta, Sa, pres, rho, drho_dp, is, npts) @@ -1345,7 +1345,7 @@ subroutine EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) call EoS_fit_range_Wright(T_min, T_max, S_min, S_max, p_min, p_max) case (EOS_WRIGHT_FULL) call EoS_fit_range_Wright_full(T_min, T_max, S_min, S_max, p_min, p_max) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call EoS_fit_range_Wright_red(T_min, T_max, S_min, S_max, p_min, p_max) case (EOS_TEOS10) call EoS_fit_range_TEOS10(T_min, T_max, S_min, S_max, p_min, p_max) @@ -1453,7 +1453,7 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) call int_spec_vol_dp_wright_red(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & @@ -1560,7 +1560,7 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & dz_neglect, useMassWghtInterp, Z_0p=Z_0p) endif - case (EOS_WRIGHT_RED) + case (EOS_WRIGHT_REDUCED) rho_scale = EOS%kg_m3_to_R pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then @@ -1606,7 +1606,7 @@ subroutine EOS_init(param_file, EOS, US) call get_param(param_file, mdl, "EQN_OF_STATE", tmpstr, & "EQN_OF_STATE determines which ocean equation of state should be used. "//& 'Currently, the valid choices are "LINEAR", "UNESCO", "JACKETT_MCD", '//& - '"WRIGHT", "WRIGHT_RED", "WRIGHT_FULL", "NEMO", "ROQUET_RHO", "ROQUET_SPV" '//& + '"WRIGHT", "WRIGHT_REDUCED", "WRIGHT_FULL", "NEMO", "ROQUET_RHO", "ROQUET_SPV" '//& 'and "TEOS10". This is only used if USE_EOS is true.', default=EOS_DEFAULT) select case (uppercase(tmpstr)) case (EOS_LINEAR_STRING) @@ -1618,7 +1618,7 @@ subroutine EOS_init(param_file, EOS, US) case (EOS_WRIGHT_STRING) EOS%form_of_EOS = EOS_WRIGHT case (EOS_WRIGHT_RED_STRING) - EOS%form_of_EOS = EOS_WRIGHT_RED + EOS%form_of_EOS = EOS_WRIGHT_REDUCED case (EOS_WRIGHT_FULL_STRING) EOS%form_of_EOS = EOS_WRIGHT_FULL case (EOS_TEOS10_STRING) @@ -1661,7 +1661,7 @@ subroutine EOS_init(param_file, EOS, US) EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & (EOS%form_of_EOS == EOS_WRIGHT) .or. & - (EOS%form_of_EOS == EOS_WRIGHT_RED) .or. & + (EOS%form_of_EOS == EOS_WRIGHT_REDUCED) .or. & (EOS%form_of_EOS == EOS_WRIGHT_FULL)) call get_param(param_file, mdl, "EOS_QUADRATURE", EOS%EOS_quadrature, & "If true, always use the generic (quadrature) code "//& @@ -2061,17 +2061,17 @@ logical function EOS_unit_tests(verbose) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_FULL EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_RED) - fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_RED", & + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_REDUCED) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_REDUCED", & rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R) - if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_RED EOS has failed some self-consistency tests.") + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_REDUCED EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail - ! This test is deliberately outside of the fit range for WRIGHT_RED, and it results in the expected warnings. - ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_RED) - ! fail = test_EOS_consistency(25.0, 15.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_RED", & + ! This test is deliberately outside of the fit range for WRIGHT_REDUCED, and it results in the expected warnings. + ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_REDUCED) + ! fail = test_EOS_consistency(25.0, 15.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_REDUCED", & ! rho_check=1012.625699301455*EOS_tmp%kg_m3_to_R) - ! if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_RED EOS has failed some self-consistency tests.") + ! if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_REDUCED EOS has failed some self-consistency tests.") ! EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT) From 63561c102a1023b6e9eb7e7021b8c37c51e005a6 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 23 Feb 2023 10:16:16 -0500 Subject: [PATCH 69/91] Removal of FMS1 I/O from FMS2 I/O infra This patch removes the calls to FMS1 I/O (fms_io_mod, mpp_io_mod) from the FMS2 infra layer, and now exclusively uses FMS2 for those operations. FMS2 I/O is currently restricted to files which use domains; files which do not use them are delegated to the native netCDF layer. The reasoning for this is that FMS is required to define the formatting of domain-decomposed I/O; for single-file I/O, this is not necessary. This does not remove all references to FMS1 I/O from MOM6, only those in the I/O layer. Several minor changes are included to accommodate the change: * MOM restart I/O now always reports its MOM domain. Previously, the domian was omitted when PARALLEL_RESTARTFILES was false, in order to trick FMS into handling this as a single file. We now generate a new domain with an IO layout of [1,1] when single-file restarts are requested. * The interface acceleration (g') was incorrectly set to the layer grid (Nk) rather than the interface grid (Nk+1). This did not appear to change any answers, but when Vertical_coordinate.nc was moved to the netCDF layer, it detected this error. This is fixed in this patch. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 4 +- config_src/infra/FMS1/MOM_domain_infra.F90 | 15 +- config_src/infra/FMS2/MOM_domain_infra.F90 | 16 +- config_src/infra/FMS2/MOM_io_infra.F90 | 972 +++++++----------- src/ALE/MOM_regridding.F90 | 4 +- src/framework/MOM_io.F90 | 9 +- src/framework/MOM_io_file.F90 | 28 +- src/framework/MOM_restart.F90 | 4 +- .../MOM_coord_initialization.F90 | 8 +- 9 files changed, 452 insertions(+), 608 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index b7d651bf55..9db4f03100 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -8,12 +8,12 @@ module MOM_cap_mod use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain use mpp_domains_mod, only: mpp_get_domain_npes -use MOM_time_manager, only: set_calendar_type, time_type, set_time, set_date, month_name +use MOM_time_manager, only: set_calendar_type, time_type, set_time, set_date use MOM_time_manager, only: GREGORIAN, JULIAN, NOLEAP use MOM_time_manager, only: operator( <= ), operator( < ), operator( >= ) use MOM_time_manager, only: operator( + ), operator( - ), operator( / ) use MOM_time_manager, only: operator( * ), operator( /= ), operator( > ) -use MOM_domains, only: MOM_infra_init, MOM_infra_end, num_pes, root_pe, pe_here +use MOM_domains, only: MOM_infra_init, MOM_infra_end use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file use MOM_get_input, only: get_MOM_input, directories use MOM_domains, only: pass_var diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 470dde0848..2a00abe32d 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -1489,7 +1489,7 @@ end subroutine get_domain_components_d2D !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & - turns, refine, extra_halo) + turns, refine, extra_halo, io_layout) type(MOM_domain_type), target, intent(in) :: MD_in !< An existing MOM_domain type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be @@ -1512,6 +1512,8 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos !! compared with MD_in + integer, optional, intent(in) :: io_layout(2) + !< A user-defined IO layout to replace the domain's IO layout logical :: mask_table_exists integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. @@ -1520,10 +1522,17 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain ! The sum of exni must equal MOM_dom%niglobal. integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. integer :: i, j, nl1, nl2 + integer :: io_layout_in(2) qturns = 0 if (present(turns)) qturns = modulo(turns, 4) + if (present(io_layout)) then + io_layout_in(:) = io_layout(:) + else + io_layout_in(:) = MD_in%io_layout(:) + endif + if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) @@ -1542,7 +1551,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS MOM_dom%layout(:) = MD_in%layout(2:1:-1) - MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + MOM_dom%io_layout(:) = io_layout_in(2:1:-1) else MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo @@ -1550,7 +1559,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS MOM_dom%layout(:) = MD_in%layout(:) - MOM_dom%io_layout(:) = MD_in%io_layout(:) + MOM_dom%io_layout(:) = io_layout_in(:) endif ! Ensure that the points per processor are the same on the source and densitation grids. diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index d845d7317b..448aecee57 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -1491,7 +1491,7 @@ end subroutine get_domain_components_d2D !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & - turns, refine, extra_halo) + turns, refine, extra_halo, io_layout) type(MOM_domain_type), target, intent(in) :: MD_in !< An existing MOM_domain type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be @@ -1514,6 +1514,9 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos !! compared with MD_in + integer, optional, intent(in) :: io_layout(2) + !< A user-defined IO layout to replace the domain's IO layout + integer :: global_indices(4) logical :: mask_table_exists @@ -1523,10 +1526,17 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain ! The sum of exni must equal MOM_dom%niglobal. integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. integer :: i, j, nl1, nl2 + integer :: io_layout_in(2) qturns = 0 if (present(turns)) qturns = modulo(turns, 4) + if (present(io_layout)) then + io_layout_in(:) = io_layout(:) + else + io_layout_in(:) = MD_in%io_layout(:) + endif + if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) @@ -1545,7 +1555,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS MOM_dom%layout(:) = MD_in%layout(2:1:-1) - MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + MOM_dom%io_layout(:) = io_layout_in(2:1:-1) else MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo @@ -1553,7 +1563,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS MOM_dom%layout(:) = MD_in%layout(:) - MOM_dom%io_layout(:) = MD_in%io_layout(:) + MOM_dom%io_layout(:) = io_layout_in(:) endif ! Ensure that the points per processor are the same on the source and densitation grids. diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 54b9dfb78b..8802761774 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -9,6 +9,7 @@ module MOM_io_infra use MOM_string_functions, only : lowercase use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file +use fms2_io_mod, only : fms2_flush_file => flush_file use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size, get_variable_units @@ -18,30 +19,28 @@ module MOM_io_infra use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited use fms2_io_mod, only : get_global_io_domain_indices use fms_io_utils_mod, only : fms2_file_exist => file_exists +use fms_io_utils_mod, only : get_filename_appendix use fms_mod, only : write_version_number, check_nml_error -use fms_io_mod, only : file_exist, field_exist, field_size, read_data -use fms_io_mod, only : fms_io_exit, get_filename_appendix use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain -use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush -use mpp_io_mod, only : mpp_write_meta, mpp_write -use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist -use mpp_io_mod, only : mpp_get_axes, mpp_axistype=>axistype, mpp_get_axis_data -use mpp_io_mod, only : mpp_get_fields, mpp_fieldtype=>fieldtype -use mpp_io_mod, only : mpp_get_info, mpp_get_times -use mpp_io_mod, only : mpp_io_init use mpp_mod, only : stdout_if_root=>stdout use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes use mpp_mod, only : mpp_get_current_pelist_name -! These are encoding constants. -use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, WRITEONLY_FILE=>MPP_WRONLY -use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY -use mpp_io_mod, only : NETCDF_FILE=>MPP_NETCDF, ASCII_FILE=>MPP_ASCII -use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, SINGLE_FILE=>MPP_SINGLE use iso_fortran_env, only : int64 implicit none ; private +! Duplication of FMS1 parameter values +! NOTE: Only kept to emulate FMS1 behavior, and may be removed in the future. +integer, parameter :: WRITEONLY_FILE = 100 +integer, parameter :: READONLY_FILE = 101 +integer, parameter :: APPEND_FILE = 102 +integer, parameter :: OVERWRITE_FILE = 103 +integer, parameter :: ASCII_FILE = 200 +integer, parameter :: NETCDF_FILE = 203 +integer, parameter :: SINGLE_FILE = 400 +integer, parameter :: MULTIPLE = 401 + ! These interfaces are actually implemented or have explicit interfaces in this file. public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix @@ -63,11 +62,6 @@ module MOM_io_infra module procedure MOM_file_exists end interface -!> Open a file (or fileset) for parallel or single-file I/O. -interface open_file - module procedure open_file_type, open_file_unit -end interface open_file - !> Read a data field from a file interface read_field module procedure read_field_4d @@ -104,11 +98,6 @@ module MOM_io_infra module procedure close_file_type, close_file_unit end interface close_file -!> Ensure that the output stream associated with a file handle is fully sent to disk -interface flush_file - module procedure flush_file_type, flush_file_unit -end interface flush_file - !> Type for holding a handle to an open file and related information type :: file_type ; private integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file @@ -119,32 +108,24 @@ module MOM_io_infra logical :: open_to_write = .false. !< If true, this file or fileset can be written to integer :: num_times !< The number of time levels in this file real :: file_time !< The time of the latest entry in the file. - logical :: FMS2_file !< If true, this file-type is to be used with FMS2 interfaces. end type file_type !> This type is a container for information about a variable in a file. type :: fieldtype ; private character(len=256) :: name !< The name of this field in the files. - type(mpp_fieldtype) :: FT !< The FMS1 field-type that this type wraps character(len=:), allocatable :: longname !< The long name for this field character(len=:), allocatable :: units !< The units for this field integer(kind=int64) :: chksum_read !< A checksum that has been read from a file logical :: valid_chksum !< If true, this field has a valid checksum value. - logical :: FMS2_field !< If true, this field-type should be used with FMS2 interfaces. end type fieldtype !> This type is a container for information about an axis in a file. type :: axistype ; private character(len=256) :: name !< The name of this axis in the files. - type(mpp_axistype) :: AT !< The FMS1 axis-type that this type wraps real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. logical :: domain_decomposed = .false. !< True if axis is domain-decomposed end type axistype -!> For now, these module-variables are hard-coded to exercise the new FMS2 interfaces. -logical :: FMS2_reads = .true. -logical :: FMS2_writes = .true. - contains !> Reads the checksum value for a field that was recorded in a file, along with a flag indicating @@ -165,11 +146,10 @@ logical function MOM_file_exists(filename, MOM_Domain) character(len=*), intent(in) :: filename !< The name of the file being inquired about type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition -! This function uses the fms_io function file_exist to determine whether -! a named file (or its decomposed variant) exists. - - MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) + type(FmsNetcdfDomainFile_t) :: fileobj + MOM_file_exists = fms2_open_file(fileobj, filename, "read", MOM_Domain%mpp_domain) + if (MOM_file_exists) call fms2_close_file(fileobj) end function MOM_file_exists !> Returns true if the named file or its domain-decomposed variant exists. @@ -196,15 +176,16 @@ subroutine close_file_type(IO_handle) if (associated(IO_handle%fileobj)) then call fms2_close_file(IO_handle%fileobj) deallocate(IO_handle%fileobj) - else - call mpp_close(IO_handle%unit) endif if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. IO_handle%num_times = 0 ; IO_handle%file_time = 0.0 - IO_handle%FMS2_file = .false. end subroutine close_file_type +! TODO: close_file_unit is only used for ASCII files, which are opened outside +! of the framework, so this could probably be removed, and those calls could +! just be replaced with close(unit). + !> closes a file. If the unit does not point to an open file, !! close_file_unit simply returns without doing anything. subroutine close_file_unit(iounit) @@ -212,45 +193,30 @@ subroutine close_file_unit(iounit) logical :: unit_is_open - ! NOTE: Files opened by `mpp_open` must be closed by `mpp_close`. Otherwise, - ! an error will occur during `fms_io_exit`. - ! - ! Since there is no way to check if `fms_io_init` was called, we are forced - ! to visually confirm that the input unit was not created by `mpp_open`. - ! - ! After `mpp_open` has been removed, this message can be deleted. inquire(iounit, opened=unit_is_open) if (unit_is_open) close(iounit) end subroutine close_file_unit !> Ensure that the output stream associated with a file handle is fully sent to disk. -subroutine flush_file_type(IO_handle) +subroutine flush_file(IO_handle) type(file_type), intent(in) :: IO_handle !< The I/O handle for the file to flush if (associated(IO_handle%fileobj)) then - ! There does not appear to be an fms2 flush call. - else - call mpp_flush(IO_handle%unit) + call fms2_flush_file(IO_handle%fileobj) endif -end subroutine flush_file_type - -!> Ensure that the output stream associated with a unit is fully sent to disk. -subroutine flush_file_unit(unit) - integer, intent(in) :: unit !< The I/O unit for the file to flush - - call mpp_flush(unit) -end subroutine flush_file_unit +end subroutine flush_file !> Initialize the underlying I/O infrastructure subroutine io_infra_init(maxunits) integer, optional, intent(in) :: maxunits !< An optional maximum number of file !! unit numbers that can be used. - call mpp_io_init(maxunit=maxunits) + + ! FMS2 requires no explicit initialization, so this is a null function. end subroutine io_infra_init !> Gracefully close out and terminate the underlying I/O infrastructure subroutine io_infra_end() - call fms_io_exit() + ! FMS2 requires no explicit finalization, so this is a null function. end subroutine io_infra_end !> Open a single namelist file that is potentially readable by all PEs. @@ -299,35 +265,7 @@ subroutine write_version(version, tag, unit) end subroutine write_version !> open_file opens a file for parallel or single-file I/O. -subroutine open_file_unit(unit, filename, action, form, threading, fileset, nohdrs, domain, MOM_domain) - integer, intent(out) :: unit !< The I/O unit for the opened file - character(len=*), intent(in) :: filename !< The name of the file being opened - integer, optional, intent(in) :: action !< A flag indicating whether the file can be read - !! or written to and how to handle existing files. - integer, optional, intent(in) :: form !< A flag indicating the format of a new file. The - !! default is ASCII_FILE, but NETCDF_FILE is also common. - integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) - !! or multiple PEs (MULTIPLE) participate in I/O. - !! With the default, the root PE does I/O. - integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due - !! to threading=MULTIPLE write to the same file (SINGLE_FILE) - !! or to one file per PE (MULTIPLE, the default). - logical, optional, intent(in) :: nohdrs !< If nohdrs is .TRUE., headers are not written to - !! ASCII files. The default is .false. - type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition - type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - - if (present(MOM_Domain)) then - call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & - nohdrs=nohdrs, domain=MOM_Domain%mpp_domain) - else - call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & - nohdrs=nohdrs, domain=domain) - endif -end subroutine open_file_unit - -!> open_file opens a file for parallel or single-file I/O. -subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fileset) +subroutine open_file(IO_handle, filename, action, MOM_domain, threading, fileset) type(file_type), intent(inout) :: IO_handle !< The handle for the opened file character(len=*), intent(in) :: filename !< The path name of the file being opened integer, optional, intent(in) :: action !< A flag indicating whether the file can be read @@ -355,63 +293,59 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi integer :: index_nc if (IO_handle%open_to_write) then - call MOM_error(WARNING, "open_file_type called for file "//trim(filename)//& + call MOM_error(WARNING, "open_file called for file "//trim(filename)//& " with an IO_handle that is already open to to write.") return endif if (IO_handle%open_to_read) then - call MOM_error(FATAL, "open_file_type called for file "//trim(filename)//& + call MOM_error(FATAL, "open_file called for file "//trim(filename)//& " with an IO_handle that is already open to to read.") endif file_mode = WRITEONLY_FILE ; if (present(action)) file_mode = action - if (FMS2_writes .and. present(MOM_Domain)) then - if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) + ! Domains are currently required to use FMS I/O. + ! NOTE: We restrict FMS2 IO usage to domain-based files due to issues with + ! string-based attributes in certain compilers. + ! But we may relax this requirement in the future. + if (.not. present(MOM_Domain)) & + call MOM_error(FATAL, 'open_file: FMS I/O requires a domain input.') - ! The FMS1 interface automatically appends .nc if necessary, but FMS2 interface does not. - index_nc = index(trim(filename), ".nc") - if (index_nc > 0) then - filename_tmp = trim(filename) - else - filename_tmp = trim(filename)//".nc" - if (is_root_PE()) call MOM_error(WARNING, "Open_file is appending .nc to the filename "//trim(filename)) - endif - - if (file_mode == WRITEONLY_FILE) then ; mode = "write" - elseif (file_mode == APPEND_FILE) then ; mode = "append" - elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" - elseif (file_mode == READONLY_FILE) then ; mode = "read" - else - call MOM_error(FATAL, "open_file_type called with unrecognized action.") - endif + if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) - IO_handle%num_times = 0 - IO_handle%file_time = 0.0 - if ((file_mode == APPEND_FILE) .and. file_exists(filename_tmp, MOM_Domain)) then - ! Determine the latest file time and number of records so far. - success = fms2_open_file(fileObj_read, trim(filename_tmp), "read", MOM_domain%mpp_domain) - call get_unlimited_dimension_name(fileObj_read, dim_unlim_name) - if (len_trim(dim_unlim_name) > 0) & - call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) - if (IO_handle%num_times > 0) & - call fms2_read_data(fileObj_read, trim(dim_unlim_name), IO_handle%file_time, & - unlim_dim_level=IO_handle%num_times) - call fms2_close_file(fileObj_read) - endif + ! The FMS1 interface automatically appends .nc if necessary, but FMS2 interface does not. + index_nc = index(trim(filename), ".nc") + if (index_nc > 0) then + filename_tmp = trim(filename) + else + filename_tmp = trim(filename)//".nc" + if (is_root_PE()) call MOM_error(WARNING, "Open_file is appending .nc to the filename "//trim(filename)) + endif - success = fms2_open_file(IO_handle%fileobj, trim(filename_tmp), trim(mode), MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename_tmp)) - IO_handle%FMS2_file = .true. - elseif (present(MOM_Domain)) then - call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & - fileset=fileset, domain=MOM_Domain%mpp_domain) - IO_handle%FMS2_file = .false. + if (file_mode == WRITEONLY_FILE) then ; mode = "write" + elseif (file_mode == APPEND_FILE) then ; mode = "append" + elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" + elseif (file_mode == READONLY_FILE) then ; mode = "read" else - call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & - fileset=fileset) - IO_handle%FMS2_file = .false. + call MOM_error(FATAL, "open_file called with unrecognized action.") endif + + IO_handle%num_times = 0 + IO_handle%file_time = 0.0 + if ((file_mode == APPEND_FILE) .and. file_exists(filename_tmp, MOM_Domain)) then + ! Determine the latest file time and number of records so far. + success = fms2_open_file(fileObj_read, trim(filename_tmp), "read", MOM_domain%mpp_domain) + call get_unlimited_dimension_name(fileObj_read, dim_unlim_name) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) + if (IO_handle%num_times > 0) & + call fms2_read_data(fileObj_read, trim(dim_unlim_name), IO_handle%file_time, & + unlim_dim_level=IO_handle%num_times) + call fms2_close_file(fileObj_read) + endif + + success = fms2_open_file(IO_handle%fileobj, trim(filename_tmp), trim(mode), MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename_tmp)) IO_handle%filename = trim(filename) if (file_mode == READONLY_FILE) then @@ -420,7 +354,7 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. endif -end subroutine open_file_type +end subroutine open_file !> open_file opens an ascii file for parallel or single-file I/O using Fortran read and write calls. subroutine open_ASCII_file(unit, file, action, threading, fileset) @@ -539,23 +473,14 @@ subroutine get_file_info(IO_handle, ndim, nvar, ntime) character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file integer :: ndims, nvars, natts, ntimes - if (IO_handle%FMS2_file) then - if (present(ndim)) ndim = get_num_dimensions(IO_handle%fileobj) - if (present(nvar)) nvar = get_num_variables(IO_handle%fileobj) - if (present(ntime)) then - ntime = 0 - call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) - if (len_trim(dim_unlim_name) > 0) & - call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) - endif - else - call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) - - if (present(ndim)) ndim = ndims - if (present(nvar)) nvar = nvars - if (present(ntime)) ntime = ntimes + if (present(ndim)) ndim = get_num_dimensions(IO_handle%fileobj) + if (present(nvar)) nvar = get_num_variables(IO_handle%fileobj) + if (present(ntime)) then + ntime = 0 + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) endif - end subroutine get_file_info @@ -575,12 +500,8 @@ subroutine get_file_times(IO_handle, time_values, ntime) if (present(ntime)) ntime = ntimes if (ntimes > 0) then allocate(time_values(ntimes)) - if (IO_handle%FMS2_file) then - call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) - call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) - else - call mpp_get_times(IO_handle%unit, time_values) - endif + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) endif end subroutine get_file_times @@ -590,7 +511,6 @@ subroutine get_file_fields(IO_handle, fields) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of !! the variables in a file. - type(mpp_fieldtype), dimension(size(fields)) :: mpp_fields ! Fieldtype structures for the variables character(len=256), dimension(size(fields)) :: var_names ! The names of all variables character(len=256) :: units ! The units of a variable as recorded in the file character(len=2048) :: longname ! The long-name of a variable as recorded in the file @@ -601,39 +521,25 @@ subroutine get_file_fields(IO_handle, fields) nvar = size(fields) ! Local variables - if (IO_handle%FMS2_file) then - call get_variable_names(IO_handle%fileobj, var_names) - do i=1,nvar - fields(i)%name = trim(var_names(i)) - longname = "" - if (variable_att_exists(IO_handle%fileobj, var_names(i), "long_name")) & - call get_variable_attribute(IO_handle%fileobj, var_names(i), "long_name", longname) - fields(i)%longname = trim(longname) - units = "" - if (variable_att_exists(IO_handle%fileobj, var_names(i), "units")) & - call get_variable_attribute(IO_handle%fileobj, var_names(i), "units", units) - fields(i)%units = trim(units) - - fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") - if (fields(i)%valid_chksum) then - call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_char) - ! If there are problems, there might need to be code added to handle commas. - read (checksum_char(1:16), '(Z16)') fields(i)%chksum_read - endif - enddo - else - call mpp_get_fields(IO_handle%unit, mpp_fields) - do i=1,nvar - fields(i)%FT = mpp_fields(i) - call mpp_get_atts(fields(i)%FT, name=fields(i)%name, units=units, longname=longname, & - checksum=checksum_file) - fields(i)%longname = trim(longname) - fields(i)%units = trim(units) - fields(i)%valid_chksum = mpp_attribute_exist(fields(i)%FT, "checksum") - if (fields(i)%valid_chksum) fields(i)%chksum_read = checksum_file(1) - enddo - endif - + call get_variable_names(IO_handle%fileobj, var_names) + do i=1,nvar + fields(i)%name = trim(var_names(i)) + longname = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "long_name")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "long_name", longname) + fields(i)%longname = trim(longname) + units = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "units")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "units", units) + fields(i)%units = trim(units) + + fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") + if (fields(i)%valid_chksum) then + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_char) + ! If there are problems, there might need to be code added to handle commas. + read (checksum_char(1:16), '(Z16)') fields(i)%chksum_read + endif + enddo end subroutine get_file_fields !> Extract information from a field type, as stored or as found in a file @@ -678,33 +584,26 @@ function field_exists(filename, field_name, domain, no_domain, MOM_domain) domainless = no_domain endif - if (FMS2_reads) then - field_exists = .false. - if (file_exists(filename)) then - if (domainless) then - success = fms2_open_file(fileObj_simple, trim(filename), "read") - if (success) then - field_exists = variable_exists(fileObj_simple, field_name) - call fms2_close_file(fileObj_simple) - endif + field_exists = .false. + if (file_exists(filename)) then + if (domainless) then + success = fms2_open_file(fileObj_simple, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileObj_simple, field_name) + call fms2_close_file(fileObj_simple) + endif + else + if (present(MOM_domain)) then + success = fms2_open_file(fileObj_dd, trim(filename), "read", MOM_domain%mpp_domain) else - if (present(MOM_domain)) then - success = fms2_open_file(fileObj_dd, trim(filename), "read", MOM_domain%mpp_domain) - else - success = fms2_open_file(fileObj_dd, trim(filename), "read", domain) - endif - if (success) then - field_exists = variable_exists(fileobj_dd, field_name) - call fms2_close_file(fileObj_dd) - endif + success = fms2_open_file(fileObj_dd, trim(filename), "read", domain) + endif + if (success) then + field_exists = variable_exists(fileobj_dd, field_name) + call fms2_close_file(fileObj_dd) endif endif - elseif (present(MOM_domain)) then - field_exists = field_exist(filename, field_name, domain=MOM_domain%mpp_domain, no_domain=no_domain) - else - field_exists = field_exist(filename, field_name, domain=domain, no_domain=no_domain) endif - end function field_exists !> Given filename and fieldname, this subroutine returns the size of the field in the file @@ -728,72 +627,68 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) integer :: size_indices(4) ! Mapping of size index to FMS1 convention integer :: idx, swap - if (FMS2_reads) then - field_exists = .false. - if (file_exists(filename)) then - success = fms2_open_file(fileObj_read, trim(filename), "read") - if (success) then - field_exists = variable_exists(fileobj_read, fieldname) - if (field_exists) then - ndims = get_variable_num_dimensions(fileobj_read, fieldname) - if (ndims > size(sizes)) call MOM_error(FATAL, & - "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) - call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) - - do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo - - ! If sizes exceeds ndims, then we fallback to the FMS1 convention - ! where sizes has at least 4 dimension, and try to position values. - if (size(sizes) > ndims) then - ! Assume FMS1 positioning rules: (nx, ny, nz, nt, ...) - if (size(sizes) < 4) & - call MOM_error(FATAL, "If sizes(:) exceeds field dimensions, "& - &"then its length must be at least 4.") - - ! Fall back to the FMS1 default values of 1 (from mpp field%size) - sizes(ndims+1:) = 1 - - ! Gather the field dimension names - allocate(dimnames(ndims)) - dimnames(:) = "" - call get_variable_dimension_names(fileObj_read, trim(fieldname), & - dimnames) - - ! Test the dimensions against standard (x,y,t) names and attributes - allocate(is_x(ndims), is_y(ndims), is_t(ndims)) - is_x(:) = .false. - is_y(:) = .false. - is_t(:) = .false. - call categorize_axes(fileObj_read, filename, ndims, dimnames, & - is_x, is_y, is_t) - - ! Currently no z-test is supported, so disable assignment with 0 - size_indices = [ & - find_index(is_x), & - find_index(is_y), & - 0, & - find_index(is_t) & - ] - - do i = 1, size(size_indices) - idx = size_indices(i) - if (idx > 0) then - swap = sizes(i) - sizes(i) = sizes(idx) - sizes(idx) = swap - endif - enddo - - deallocate(is_x, is_y, is_t) - deallocate(dimnames) - endif + field_exists = .false. + if (file_exists(filename)) then + success = fms2_open_file(fileObj_read, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileobj_read, fieldname) + if (field_exists) then + ndims = get_variable_num_dimensions(fileobj_read, fieldname) + if (ndims > size(sizes)) call MOM_error(FATAL, & + "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) + call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) + + do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + + ! If sizes exceeds ndims, then we fallback to the FMS1 convention + ! where sizes has at least 4 dimension, and try to position values. + if (size(sizes) > ndims) then + ! Assume FMS1 positioning rules: (nx, ny, nz, nt, ...) + if (size(sizes) < 4) & + call MOM_error(FATAL, "If sizes(:) exceeds field dimensions, "& + &"then its length must be at least 4.") + + ! Fall back to the FMS1 default values of 1 (from mpp field%size) + sizes(ndims+1:) = 1 + + ! Gather the field dimension names + allocate(dimnames(ndims)) + dimnames(:) = "" + call get_variable_dimension_names(fileObj_read, trim(fieldname), & + dimnames) + + ! Test the dimensions against standard (x,y,t) names and attributes + allocate(is_x(ndims), is_y(ndims), is_t(ndims)) + is_x(:) = .false. + is_y(:) = .false. + is_t(:) = .false. + call categorize_axes(fileObj_read, filename, ndims, dimnames, & + is_x, is_y, is_t) + + ! Currently no z-test is supported, so disable assignment with 0 + size_indices = [ & + find_index(is_x), & + find_index(is_y), & + 0, & + find_index(is_t) & + ] + + do i = 1, size(size_indices) + idx = size_indices(i) + if (idx > 0) then + swap = sizes(i) + sizes(i) = sizes(idx) + sizes(idx) = swap + endif + enddo + + deallocate(is_x, is_y, is_t) + deallocate(dimnames) endif endif endif - if (present(field_found)) field_found = field_exists - else - call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) endif + if (present(field_found)) field_found = field_exists end subroutine get_field_size @@ -830,10 +725,7 @@ subroutine get_axis_data( axis, dat ) if (size(axis%ax_data) > size(dat)) call MOM_error(FATAL, & "get_axis_data called with too small of an output data array for "//trim(axis%name)) do i=1,size(axis%ax_data) ; dat(i) = axis%ax_data(i) ; enddo - elseif (.not.FMS2_writes) then - call mpp_get_axis_data( axis%AT, dat ) endif - end subroutine get_axis_data !> This routine uses the fms_io subroutine read_data to read a scalar named @@ -859,7 +751,7 @@ subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (present(MOM_Domain) .and. FMS2_reads) then + if (present(MOM_Domain)) then ! Open the FMS2 file-set. success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -877,7 +769,7 @@ subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) - elseif (FMS2_reads) then + else ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -896,10 +788,6 @@ subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj)) call fms2_close_file(fileobj) - elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) - else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) endif if (present(scale)) then ; if (scale /= 1.0) then @@ -931,7 +819,7 @@ subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (present(MOM_Domain) .and. FMS2_reads) then + if (present(MOM_Domain)) then ! Open the FMS2 file-set. success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -949,7 +837,7 @@ subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) - elseif (FMS2_reads) then + else ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -968,10 +856,6 @@ subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj)) call fms2_close_file(fileobj) - elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) - else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) endif if (present(scale)) then ; if (scale /= 1.0) then @@ -1004,29 +888,24 @@ subroutine read_field_2d(filename, fieldname, data, MOM_Domain, & logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, "read_field_2d: ", filename, & - var_to_read, has_time_dim, timelevel, position) + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_2d: ", filename, & + var_to_read, has_time_dim, timelevel, position) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif - - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) endif ; endif @@ -1060,7 +939,7 @@ subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_dom character(len=96) :: var_to_read ! Name of variable to read from the netcdf file logical :: success ! True if the file was successfully opened - if (present(MOM_Domain) .and. FMS2_reads) then + if (present(MOM_Domain)) then ! Open the FMS2 file-set. success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -1074,7 +953,7 @@ subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_dom ! Close the file-set. if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) - elseif (FMS2_reads) then + else ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -1088,11 +967,6 @@ subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_dom ! Close the file-set. if (check_if_open(fileobj)) call fms2_close_file(fileobj) - elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & - no_domain=no_domain) - else - call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) endif if (present(scale)) then ; if (scale /= 1.0) then @@ -1130,29 +1004,24 @@ subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - - ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, "read_field_3d: ", filename, & - var_to_read, has_time_dim, timelevel, position) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_3d: ", filename, & + var_to_read, has_time_dim, timelevel, position) - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) endif ; endif @@ -1182,29 +1051,24 @@ subroutine read_field_4d(filename, fieldname, data, MOM_Domain, & character(len=96) :: var_to_read ! Name of variable to read from the netcdf file logical :: success ! True if the file was successfully opened - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, "read_field_4d: ", filename, & - var_to_read, has_time_dim, timelevel, position) + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_4d: ", filename, & + var_to_read, has_time_dim, timelevel, position) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif - - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) endif ; endif @@ -1226,29 +1090,25 @@ subroutine read_field_0d_int(filename, fieldname, data, timelevel) logical :: success ! If true, the file was opened successfully ! This routine might not be needed for MOM6. - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileObj, trim(filename), "read") - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Find the matching case-insensitive variable name in the file, and determine whether it - ! has a time dimension. - call find_varname_in_file(fileObj, fieldname, "read_field_0d_int: ", filename, & - var_to_read, has_time_dim, timelevel) + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_0d_int: ", filename, & + var_to_read, has_time_dim, timelevel) - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) end subroutine read_field_0d_int !> This routine uses the fms_io subroutine read_data to read a 1-D integer @@ -1267,29 +1127,25 @@ subroutine read_field_1d_int(filename, fieldname, data, timelevel) logical :: success ! If true, the file was opened successfully ! This routine might not be needed for MOM6. - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileObj, trim(filename), "read") - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Find the matching case-insensitive variable name in the file, and determine whether it - ! has a time dimension. - call find_varname_in_file(fileObj, fieldname, "read_field_1d_int: ", filename, & - var_to_read, has_time_dim, timelevel) + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_1d_int: ", filename, & + var_to_read, has_time_dim, timelevel) - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) end subroutine read_field_1d_int @@ -1325,36 +1181,29 @@ subroutine read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MO elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif endif - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - - ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. - call prepare_to_read_var(fileobj, u_fieldname, "read_vector_2d: ", filename, & - u_var, has_time_dim, timelevel, position=u_pos) - call prepare_to_read_var(fileobj, v_fieldname, "read_vector_2d: ", filename, & - v_var, has_time_dim, timelevel, position=v_pos) - - ! Read the u-data and v-data. There would already been an error message for one - ! of the variables if they are inconsistent in having an unlimited dimension. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) - call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, u_var, u_data) - call fms2_read_data(fileobj, v_var, v_data) - endif - - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=u_pos) - call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=v_pos) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "read_vector_2d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "read_vector_2d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data. There would already been an error message for one + ! of the variables if they are inconsistent in having an unlimited dimension. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, u_data, scale) call rescale_comp_data(MOM_Domain, v_data, scale) @@ -1395,36 +1244,29 @@ subroutine read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MO elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif endif - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - - ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. - call prepare_to_read_var(fileobj, u_fieldname, "read_vector_3d: ", filename, & - u_var, has_time_dim, timelevel, position=u_pos) - call prepare_to_read_var(fileobj, v_fieldname, "read_vector_3d: ", filename, & - v_var, has_time_dim, timelevel, position=v_pos) - - ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. - ! There would already been an error message for one of the variables if they are inconsistent. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) - call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, u_var, u_data) - call fms2_read_data(fileobj, v_var, v_data) - endif - - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=u_pos) - call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=v_pos) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "read_vector_3d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "read_vector_3d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. + ! There would already been an error message for one of the variables if they are inconsistent. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, u_data, scale) call rescale_comp_data(MOM_Domain, v_data, scale) @@ -1807,14 +1649,11 @@ subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_4d @@ -1831,14 +1670,11 @@ subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_3d @@ -1855,14 +1691,11 @@ subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_2d @@ -1876,13 +1709,11 @@ subroutine write_field_1d(IO_handle, field_md, field, tstamp) ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_1d @@ -1896,13 +1727,11 @@ subroutine write_field_0d(IO_handle, field_md, field, tstamp) ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_0d @@ -1918,11 +1747,9 @@ integer function write_time_if_later(IO_handle, field_time) if ((field_time > IO_handle%file_time) .or. (IO_handle%num_times == 0)) then IO_handle%file_time = field_time IO_handle%num_times = IO_handle%num_times + 1 - if (IO_handle%FMS2_file) then - call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) - call write_data(IO_handle%fileobj, trim(dim_unlim_name), (/field_time/), & - corner=(/IO_handle%num_times/), edge_lengths=(/1/)) - endif + call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + call write_data(IO_handle%fileobj, trim(dim_unlim_name), (/field_time/), & + corner=(/IO_handle%num_times/), edge_lengths=(/1/)) endif write_time_if_later = IO_handle%num_times @@ -1935,18 +1762,13 @@ subroutine MOM_write_axis(IO_handle, axis) integer :: is, ie - if (IO_handle%FMS2_file) then - if (axis%domain_decomposed) then - ! FMS2 does not domain-decompose 1d arrays, so we explicitly slice it - call get_global_io_domain_indices(IO_handle%fileobj, trim(axis%name), is, ie) - call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data(is:ie)) - else - call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) - endif + if (axis%domain_decomposed) then + ! FMS2 does not domain-decompose 1d arrays, so we explicitly slice it + call get_global_io_domain_indices(IO_handle%fileobj, trim(axis%name), is, ie) + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data(is:ie)) else - call mpp_write(IO_handle%unit, axis%AT) + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) endif - end subroutine MOM_write_axis !> Store information about an axis in a previously defined axistype and write this @@ -1973,12 +1795,10 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian integer :: position ! A flag indicating the axis staggering position. integer :: i, isc, iec, global_size - if (IO_handle%FMS2_file) then - if (is_dimension_registered(IO_handle%fileobj, trim(name))) then - call MOM_error(FATAL, "write_metadata_axis was called more than once for axis "//trim(name)//& - " in file "//trim(IO_handle%filename)) - return - endif + if (is_dimension_registered(IO_handle%fileobj, trim(name))) then + call MOM_error(FATAL, "write_metadata_axis was called more than once for axis "//trim(name)//& + " in file "//trim(IO_handle%filename)) + return endif axis%name = trim(name) @@ -1986,82 +1806,73 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian "Data is already allocated in a call to write_metadata_axis for axis "//& trim(name)//" in file "//trim(IO_handle%filename)) - if (IO_handle%FMS2_file) then - is_x = .false. ; is_y = .false. ; is_t = .false. - position = CENTER - if (present(cartesian)) then - cart = trim(adjustl(cartesian)) - if ((index(cart, "X") == 1) .or. (index(cart, "x") == 1)) is_x = .true. - if ((index(cart, "Y") == 1) .or. (index(cart, "y") == 1)) is_y = .true. - if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. - endif - - ! For now, we assume that all horizontal axes are domain-decomposed. - if (is_x .or. is_y) & - axis%domain_decomposed = .true. - - if (is_x) then - if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif - call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) - elseif (is_y) then - if (present(edge_axis)) then ; if (edge_axis) position = NORTH_FACE ; endif - call register_axis(IO_handle%fileobj, trim(name), 'y', domain_position=position) - elseif (is_t .and. .not.present(data)) then - ! This is the unlimited (time) dimension. - call register_axis(IO_handle%fileobj, trim(name), unlimited) - else - if (.not.present(data)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& - "An axis_length argument is required to register the axis "//trim(name)) - call register_axis(IO_handle%fileobj, trim(name), size(data)) - endif + is_x = .false. ; is_y = .false. ; is_t = .false. + position = CENTER + if (present(cartesian)) then + cart = trim(adjustl(cartesian)) + if ((index(cart, "X") == 1) .or. (index(cart, "x") == 1)) is_x = .true. + if ((index(cart, "Y") == 1) .or. (index(cart, "y") == 1)) is_y = .true. + if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. + endif - if (present(data)) then - ! With FMS2, the data for the axis labels has to match the computational domain on this PE. - if (present(domain)) then - ! The commented-out code on the next ~11 lines runs but there is missing data in the output file - ! call mpp_get_compute_domain(domain, isc, iec) - ! call mpp_get_global_domain(domain, size=global_size) - ! if (size(data) == global_size) then - ! allocate(axis%ax_data(iec+1-isc)) ; axis%ax_data(:) = data(isc:iec) - ! ! A simpler set of labels: do i=1,iec-isc ; axis%ax_data(i) = real(isc + i) - 1.0 ; enddo - ! elseif (size(data) == global_size+1) then - ! ! This is an edge axis. Note the effective SW indexing convention here. - ! allocate(axis%ax_data(iec+2-isc)) ; axis%ax_data(:) = data(isc:iec+1) - ! ! A simpler set of labels: do i=1,iec+1-isc ; axis%ax_data(i) = real(isc + i) - 1.5 ; enddo - ! else - ! call MOM_error(FATAL, "Unexpected size of data for "//trim(name)//" in write_metadata_axis.") - ! endif - - ! This works for a simple 1x1 IO layout, but gives errors for nontrivial IO layouts - allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) - - else ! Store the entire array of axis labels. - allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) - endif - endif + ! For now, we assume that all horizontal axes are domain-decomposed. + if (is_x .or. is_y) & + axis%domain_decomposed = .true. + + if (is_x) then + if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) + elseif (is_y) then + if (present(edge_axis)) then ; if (edge_axis) position = NORTH_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'y', domain_position=position) + elseif (is_t .and. .not.present(data)) then + ! This is the unlimited (time) dimension. + call register_axis(IO_handle%fileobj, trim(name), unlimited) + else + if (.not.present(data)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& + "An axis_length argument is required to register the axis "//trim(name)) + call register_axis(IO_handle%fileobj, trim(name), size(data)) + endif + if (present(data)) then + ! With FMS2, the data for the axis labels has to match the computational domain on this PE. + if (present(domain)) then + ! The commented-out code on the next ~11 lines runs but there is missing data in the output file + ! call mpp_get_compute_domain(domain, isc, iec) + ! call mpp_get_global_domain(domain, size=global_size) + ! if (size(data) == global_size) then + ! allocate(axis%ax_data(iec+1-isc)) ; axis%ax_data(:) = data(isc:iec) + ! ! A simpler set of labels: do i=1,iec-isc ; axis%ax_data(i) = real(isc + i) - 1.0 ; enddo + ! elseif (size(data) == global_size+1) then + ! ! This is an edge axis. Note the effective SW indexing convention here. + ! allocate(axis%ax_data(iec+2-isc)) ; axis%ax_data(:) = data(isc:iec+1) + ! ! A simpler set of labels: do i=1,iec+1-isc ; axis%ax_data(i) = real(isc + i) - 1.5 ; enddo + ! else + ! call MOM_error(FATAL, "Unexpected size of data for "//trim(name)//" in write_metadata_axis.") + ! endif + + ! This works for a simple 1x1 IO layout, but gives errors for nontrivial IO layouts + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) - ! Now create the variable that describes this axis. - call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) - if (len_trim(longname) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & - trim(longname), len_trim(longname)) - if (len_trim(units) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & - trim(units), len_trim(units)) - if (present(cartesian)) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & - trim(cartesian), len_trim(cartesian)) - if (present(sense)) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) - else - if (present(data)) then + else ! Store the entire array of axis labels. allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) endif - - call mpp_write_meta(IO_handle%unit, axis%AT, name, units, longname, cartesian=cartesian, sense=sense, & - domain=domain, data=data, calendar=calendar) endif + + + ! Now create the variable that describes this axis. + call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(cartesian)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & + trim(cartesian), len_trim(cartesian)) + if (present(sense)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) end subroutine write_metadata_axis !> Store information about an output variable in a previously defined fieldtype and write this @@ -2083,35 +1894,27 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & ! Local variables character(len=256), dimension(size(axes)) :: dim_names ! The names of the dimensions - type(mpp_axistype), dimension(size(axes)) :: mpp_axes ! The array of mpp_axistypes for this variable character(len=16) :: prec_string ! A string specifying the precision with which to save this variable character(len=64) :: checksum_string ! checksum character array created from checksum argument integer :: i, ndims ndims = size(axes) - if (IO_handle%FMS2_file) then - do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo - prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif - call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) - if (len_trim(longname) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & - trim(longname), len_trim(longname)) - if (len_trim(units) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & - trim(units), len_trim(units)) - if (present(standard_name)) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & - trim(standard_name), len_trim(standard_name)) - if (present(checksum)) then - write (checksum_string,'(Z16)') checksum(1) ! Z16 is the hexadecimal format code - call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & - trim(checksum_string), len_trim(checksum_string)) - endif - else - do i=1,ndims ; mpp_axes(i) = axes(i)%AT ; enddo - call mpp_write_meta(IO_handle%unit, field%FT, mpp_axes, name, units, longname, & - pack=pack, standard_name=standard_name, checksum=checksum) - ! unused opt. args: min=min, max=max, fill=fill, scale=scale, add=add, & + do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo + prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif + call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(standard_name)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & + trim(standard_name), len_trim(standard_name)) + if (present(checksum)) then + write (checksum_string,'(Z16)') checksum(1) ! Z16 is the hexadecimal format code + call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & + trim(checksum_string), len_trim(checksum_string)) endif ! Store information in the field-type, regardless of which interfaces are used. @@ -2129,12 +1932,7 @@ subroutine write_metadata_global(IO_handle, name, attribute) character(len=*), intent(in) :: name !< The name in the file of this global attribute character(len=*), intent(in) :: attribute !< The value of this attribute - if (IO_handle%FMS2_file) then - call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) - else - call mpp_write_meta(IO_handle%unit, name, cval=attribute) - endif - + call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) end subroutine write_metadata_global end module MOM_io_infra diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 8194176c15..74b7bc784a 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -7,7 +7,7 @@ module MOM_regridding use MOM_file_parser, only : param_file_type, get_param, log_param use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data use MOM_io, only : vardesc, var_desc, SINGLE_FILE -use MOM_io, only : MOM_infra_file, MOM_field +use MOM_io, only : MOM_netCDF_file, MOM_field use MOM_io, only : create_MOM_file, MOM_write_field use MOM_io, only : verify_variable_units, slasher use MOM_unit_scaling, only : unit_scale_type @@ -2082,7 +2082,7 @@ subroutine write_regrid_file( CS, GV, filepath ) type(vardesc) :: vars(2) type(MOM_field) :: fields(2) - type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset + type(MOM_netCDF_file) :: IO_handle ! The I/O handle of the fileset real :: ds(GV%ke), dsi(GV%ke+1) if (CS%regridding_scheme == REGRIDDING_HYBGEN) then diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 727abda795..6bde678eb4 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -332,13 +332,16 @@ subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & IsgB = dG%IsgB ; IegB = dG%IegB ; JsgB = dG%JsgB ; JegB = dG%JegB endif - if (domain_set .and. (num_PEs() == 1)) thread = SINGLE_FILE - one_file = .true. if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call IO_handle%open(filename, action=OVERWRITE_FILE, threading=thread) + if (domain_set) then + call IO_handle%open(filename, action=OVERWRITE_FILE, & + MOM_domain=domain, threading=thread) + else + call IO_handle%open(filename, action=OVERWRITE_FILE, threading=thread) + endif else call IO_handle%open(filename, action=OVERWRITE_FILE, MOM_domain=Domain) endif diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index e1613fbbb3..6909e597ba 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -6,6 +6,8 @@ module MOM_io_file use, intrinsic :: iso_fortran_env, only : int64 use MOM_domains, only : MOM_domain_type, domain1D +use MOM_domains, only : clone_MOM_domain +use MOM_domains, only : deallocate_MOM_domain use MOM_io_infra, only : file_type, get_file_info, get_file_fields use MOM_io_infra, only : open_file, close_file, flush_file use MOM_io_infra, only : fms2_file_is_open => file_is_open @@ -14,6 +16,7 @@ module MOM_io_file use MOM_io_infra, only : write_field, write_metadata use MOM_io_infra, only : get_field_atts use MOM_io_infra, only : read_field_chksum +use MOM_io_infra, only : SINGLE_FILE use MOM_hor_index, only : hor_index_type use MOM_hor_index, only : hor_index_init @@ -248,6 +251,9 @@ module MOM_io_file type, extends(MOM_file) :: MOM_infra_file private + type(MOM_domain_type), public, pointer :: domain => null() + !< Internal domain used for single-file IO + ! NOTE: This will be made private after the API transition type(file_type), public :: handle_infra !< Framework-specific file handler content @@ -919,8 +925,23 @@ subroutine open_file_infra(handle, filename, action, MOM_domain, threading, file integer, intent(in), optional :: threading integer, intent(in), optional :: fileset - call open_file(handle%handle_infra, filename, action=action, & - MOM_domain=MOM_domain, threading=threading, fileset=fileset) + logical :: use_single_file_domain + ! True if the domain is replaced with a single-file IO layout. + + use_single_file_domain = .false. + if (present(MOM_domain) .and. present(threading)) then + if (threading == SINGLE_FILE) & + use_single_file_domain = .true. + endif + + if (use_single_file_domain) then + call clone_MOM_domain(MOM_domain, handle%domain, io_layout=[1,1]) + call open_file(handle%handle_infra, filename, action=action, & + MOM_domain=handle%domain, threading=threading, fileset=fileset) + else + call open_file(handle%handle_infra, filename, action=action, & + MOM_domain=MOM_domain, threading=threading, fileset=fileset) + endif call handle%axes%init() call handle%fields%init() @@ -930,6 +951,9 @@ end subroutine open_file_infra subroutine close_file_infra(handle) class(MOM_infra_file), intent(inout) :: handle + if (associated(handle%domain)) & + call deallocate_MOM_domain(handle%domain) + call close_file(handle%handle_infra) call handle%axes%finalize() call handle%fields%finalize() diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 24ba0fa76b..75051c32ba 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1860,7 +1860,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, nf = nf + 1 if (present(IO_handles)) & call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) + MOM_domain=G%Domain, threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(nf) = .true. if (present(file_paths)) file_paths(nf) = filepath elseif (CS%parallel_restartfiles) then @@ -1892,7 +1892,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, nf = nf + 1 if (present(IO_handles)) & call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) + MOM_Domain=G%Domain, threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(nf) = .true. if (present(file_paths)) file_paths(nf) = filepath if (is_root_pe() .and. (present(IO_handles))) & diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 78f739c461..8af8cd3bc6 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -9,7 +9,7 @@ module MOM_coord_initialization use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, read_param, log_param, param_file_type, log_version use MOM_io, only : create_MOM_file, file_exists -use MOM_io, only : MOM_infra_file, MOM_field +use MOM_io, only : MOM_netCDF_file, MOM_field use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE use MOM_string_functions, only : slasher, uppercase use MOM_unit_scaling, only : unit_scale_type @@ -528,12 +528,12 @@ subroutine write_vertgrid_file(GV, US, param_file, directory) character(len=240) :: filepath type(vardesc) :: vars(2) type(MOM_field) :: fields(2) - type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset + type(MOM_netCDF_file) :: IO_handle ! The I/O handle of the fileset - filepath = trim(directory) // trim("Vertical_coordinate") + filepath = trim(directory) // trim("Vertical_coordinate.nc") vars(1) = var_desc("R","kilogram meter-3","Target Potential Density",'1','L','1') - vars(2) = var_desc("g","meter second-2","Reduced gravity",'1','L','1') + vars(2) = var_desc("g","meter second-2","Reduced gravity",'1','i','1') call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & SINGLE_FILE, GV=GV) From c9b920bb8224404a0144daba146be88d413bd0db Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 30 Mar 2023 16:52:26 -0400 Subject: [PATCH 70/91] Remove FMS1 calls from MOM_domains_infra --- config_src/infra/FMS2/MOM_domain_infra.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 448aecee57..de580d98d9 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -23,7 +23,7 @@ module MOM_domain_infra use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST -use fms_io_mod, only : file_exist, parse_mask_table +use fms_io_utils_mod, only : file_exists, parse_mask_table use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get ! This subroutine is not in MOM6/src but may be required by legacy drivers @@ -1390,7 +1390,7 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l endif if (present(mask_table)) then - mask_table_exists = file_exist(mask_table) + mask_table_exists = file_exists(mask_table) if (mask_table_exists) then allocate(MOM_dom%maskmap(layout(1), layout(2))) call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name) From f5423cb96e69d41e902796ecffcbd88d978ffecf Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sun, 2 Apr 2023 10:19:27 -0400 Subject: [PATCH 71/91] Add .nc extension to ALE Vertical_coordinate. The `Vertical_coordinate.nc` files has two points of creation, MOM_coord_initialization and MOM_ALE. Having moved the file from the infra to netCDF I/O layer, the .nc extension is no longer automatically applied. The extension was explicitly added to `Vertical_coordinate` in MOM_coord_initialization, but not to MOM_ALE. This patch adds the extension. Thanks to Kate Hedstrom for detecting this and Keith Lindsay for the proposed fix. --- src/ALE/MOM_ALE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 137f6cee9b..e40bba3e2f 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1456,7 +1456,7 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) character(len=240) :: filepath - filepath = trim(directory) // trim("Vertical_coordinate") + filepath = trim(directory) // trim("Vertical_coordinate.nc") call write_regrid_file(CS%regridCS, GV, filepath) From ac11984fdb14f905e7a0cc70dc93bcc1443c12bf Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 26 Apr 2023 15:22:38 -0400 Subject: [PATCH 72/91] Reversion of MOM_mixed_layer_restrat growth_time Due to some machines reporting a regression in the mixed layer restratification code, this patch reverts the calculation of the growth time in a separate function. Most of the content related to comments and parameter setup have been retained, even if those parameters are no longer used. --- .../lateral/MOM_mixed_layer_restrat.F90 | 89 +++++++++++++++++-- 1 file changed, 81 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index ffdf236152..fe31eb0de3 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -159,6 +159,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] @@ -194,6 +195,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] logical :: line_is_empty, keep_going, res_upscale integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -205,6 +208,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var covTS(:) = 0.0 !!Functionality not implemented yet; in future, should be passed in tv varS(:) = 0.0 + vonKar_x_pi2 = CS%vonKar * 9.8696 + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & @@ -316,7 +321,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,timescale, & + !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & !$OMP line_is_empty, keep_going,res_scaling_fac, & !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) @@ -379,21 +384,40 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !$OMP do do j=js,je ; do I=is-1,ie u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i+1,j) ) ) + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef + if (res_upscale) timescale = timescale * res_scaling_fac uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) ! As above but using the slow filtered MLD h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef2 + if (res_upscale) timescale = timescale * res_scaling_fac uDml_slow(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) @@ -447,21 +471,40 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !$OMP do do J=js-1,je ; do i=is,ie u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( (G%dxCv(i,J))**2 + (G%dyCv(i,J))**2 ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i,j+1) ) ) + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef + if (res_upscale) timescale = timescale * res_scaling_fac vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) ! As above but using the slow filtered MLD h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef2 + if (res_upscale) timescale = timescale * res_scaling_fac vDml_slow(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) @@ -608,6 +651,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] @@ -642,6 +688,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt g_Rho0 = GV%g_Earth / GV%Rho0 + vonKar_x_pi2 = CS%vonKar * 9.8696 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z @@ -657,7 +704,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,timescale, & + !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & !$OMP I2htot,z_topx2,hx2,a) & !$OMP firstprivate(uDml,vDml) !$OMP do @@ -689,8 +736,19 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & @@ -729,8 +787,19 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & @@ -799,6 +868,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) end subroutine mixedlayer_restrat_BML +! NOTE: This function appears to change answers on some platforms, so it is +! currently unused in the model, but we intend to introduce it in the future. + !> Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) real, intent(in) :: u_star !< Surface friction velocity [Z T-1 ~> m s-1] @@ -945,6 +1017,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) endif + call get_param(param_file, mdl, "KV_RESTRAT", CS%Kv_restrat, & "A small viscosity that sets a floor on the momentum mixing rate during "//& "restratification. If this is positive, it will prevent some possible "//& From 82f750e58a08543c5f9ce8eb7bb587533ae60ba4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Apr 2023 08:51:41 -0400 Subject: [PATCH 73/91] +Remove optional argument eta_to_m from find_eta Eliminate the unused optional argument eta_to_m from the two find_eta routines for simplicity and code clarity. These were used during the transition of the units of the interface height variables, but they are now using [Z ~> m] units everywhere, with the unscaling occurring via conversion factors in the register_diag calls. All answers are bitwise identical, but there is al optional argument that is removed from a public interface. --- src/core/MOM_interface_heights.F90 | 53 +++++++++++------------------- 1 file changed, 20 insertions(+), 33 deletions(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 7047dd6421..af444de941 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -28,15 +28,14 @@ module MOM_interface_heights !! form for consistency with the calculation of the pressure gradient forces. !! Additionally, these height may be dilated for consistency with the !! corresponding time-average quantity from the barotropic calculation. -subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref) +subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: eta !< layer interface heights - !! [Z ~> m] or [1/eta_to_m m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: eta !< layer interface heights [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable !! that gives the "correct" free surface height (Boussinesq) or total water !! column mass per unit area (non-Boussinesq). This is used to dilate the layer @@ -44,8 +43,6 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref !! In Boussinesq mode, eta_bt and G%bathyT use the same reference height. integer, optional, intent(in) :: halo_size !< width of halo points on !! which to calculate eta. - real, optional, intent(in) :: eta_to_m !< The conversion factor from - !! the units of eta to m; by default this is US%Z_to_m. real, optional, intent(in) :: dZref !< The difference in the !! reference height between G%bathyT and eta [Z ~> m]. The default is 0. @@ -57,7 +54,6 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] real :: I_gEarth ! The inverse of the gravitational acceleration times the ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] - real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. ! dZ_ref is 0 unless the optional argument dZref is present. integer i, j, k, isv, iev, jsv, jev, nz, halo @@ -70,20 +66,17 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref if ((isvG%ied) .or. (jsvG%jed)) & call MOM_error(FATAL,"find_eta called with an overly large halo_size.") - Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m - H_to_eta = GV%H_to_Z * Z_to_eta - H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / GV%g_Earth + I_gEarth = 1.0 / GV%g_Earth dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref !$OMP parallel default(shared) private(dilate,htot) !$OMP do - do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -Z_to_eta*(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo + do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo if (GV%Boussinesq) then !$OMP do do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*H_to_eta + eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo if (present(eta_bt)) then ! Dilate the water column to agree with the free surface height @@ -91,12 +84,12 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref !$OMP do do j=jsv,jev do i=isv,iev - dilate(i) = (eta_bt(i,j)*H_to_eta + Z_to_eta*G%bathyT(i,j)) / & - (eta(i,j,1) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) + dilate(i) = (eta_bt(i,j)*GV%H_to_Z + G%bathyT(i,j)) / & + (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) enddo do k=1,nz ; do i=isv,iev - eta(i,j,K) = dilate(i) * (eta(i,j,K) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) - & - Z_to_eta*(G%bathyT(i,j) + dZ_ref) + eta(i,j,K) = dilate(i) * (eta(i,j,K) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) enddo ; enddo enddo endif @@ -127,7 +120,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref else !$OMP do do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + H_to_rho_eta*h(i,j,k) / GV%Rlay(k) + eta(i,j,K) = eta(i,j,K+1) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k) enddo ; enddo ; enddo endif if (present(eta_bt)) then @@ -139,8 +132,8 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref do k=1,nz ; do i=isv,iev ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=isv,iev ; dilate(i) = eta_bt(i,j) / htot(i) ; enddo do k=1,nz ; do i=isv,iev - eta(i,j,K) = dilate(i) * (eta(i,j,K) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) - & - Z_to_eta*(G%bathyT(i,j) + dZ_ref) + eta(i,j,K) = dilate(i) * (eta(i,j,K) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) enddo ; enddo enddo endif @@ -153,7 +146,7 @@ end subroutine find_eta_3d !! with the calculation of the pressure gradient forces. Additionally, the sea !! surface height may be adjusted for consistency with the corresponding !! time-average quantity from the barotropic calculation. -subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref) +subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -168,8 +161,6 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref !! In Boussinesq mode, eta_bt and G%bathyT use the same reference height. integer, optional, intent(in) :: halo_size !< width of halo points on !! which to calculate eta. - real, optional, intent(in) :: eta_to_m !< The conversion factor from - !! the units of eta to m; by default this is US%Z_to_m. real, optional, intent(in) :: dZref !< The difference in the !! reference height between G%bathyT and eta [Z ~> m]. The default is 0. @@ -181,7 +172,6 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref real :: htot(SZI_(G)) ! The sum of all layers' thicknesses [H ~> m or kg m-2]. real :: I_gEarth ! The inverse of the gravitational acceleration times the ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] - real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. ! dZ_ref is 0 unless the optional argument dZref is present. integer i, j, k, is, ie, js, je, nz, halo @@ -190,26 +180,23 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo nz = GV%ke - Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m - H_to_eta = GV%H_to_Z * Z_to_eta - H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / GV%g_Earth + I_gEarth = 1.0 / GV%g_Earth dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref !$OMP parallel default(shared) private(htot) !$OMP do - do j=js,je ; do i=is,ie ; eta(i,j) = -Z_to_eta*(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo + do j=js,je ; do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo if (GV%Boussinesq) then if (present(eta_bt)) then !$OMP do do j=js,je ; do i=is,ie - eta(i,j) = H_to_eta*eta_bt(i,j) - Z_to_eta*dZ_ref + eta(i,j) = GV%H_to_Z*eta_bt(i,j) - dZ_ref enddo ; enddo else !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + h(i,j,k)*H_to_eta + eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo endif else @@ -238,7 +225,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref else !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + H_to_rho_eta*h(i,j,k) / GV%Rlay(k) + eta(i,j) = eta(i,j) + GV%H_to_RZ*h(i,j,k) / GV%Rlay(k) enddo ; enddo ; enddo endif if (present(eta_bt)) then @@ -249,8 +236,8 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref do i=is,ie ; htot(i) = GV%H_subroundoff ; enddo do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=is,ie - eta(i,j) = (eta_bt(i,j) / htot(i)) * (eta(i,j) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) - & - Z_to_eta*(G%bathyT(i,j) + dZ_ref) + eta(i,j) = (eta_bt(i,j) / htot(i)) * (eta(i,j) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) enddo enddo endif From 3b11e430e3bfbdca4fe9813bb1684eaae5ecaafa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Apr 2023 10:42:07 -0400 Subject: [PATCH 74/91] +Initialize thicknesses in height units Pass arguments in height units rather than thickness units to most of the routines that initialize thickness or temperatures and salinities. These routines are already undoing this scaling and working in height units, and it is not possible to convert thicknesses to thickness units in non-Boussinesq mode until the temperatures and salinities are also known. The routines whose argument units are altered include: - initialize_thickness_uniform - initialize_thickness_list - DOME_initialize_thickness - ISOMIP_initialize_thickness - benchmark_initialize_thickness - Neverworld_initialize_thickness - circle_obcs_initialize_thickness - lock_exchange_initialize_thickness - external_gwave_initialize_thickness - DOME2d_initialize_thickness - adjustment_initialize_thickness - sloshing_initialize_thickness - seamount_initialize_thickness - dumbbell_initialize_thickness - soliton_initialize_thickness - Phillips_initialize_thickness - Rossby_front_initialize_thickness - user_initialize_thickness - DOME2d_initialize_temperature_salinity - ISOMIP_initialize_temperature_salinity - adjustment_initialize_temperature_salinity - baroclinic_zone_init_temperature_salinity - sloshing_initialize_temperature_salinity - seamount_initialize_temperature_salinity - dumbbell_initialize_temperature_salinity - Rossby_front_initialize_temperature_salinity - SCM_CVMix_tests_TS_init - dense_water_initialize_TS - adjustEtaToFitBathymetry Similar changes were made internally to MOM_temp_salt_initialize_from_Z to defer the transition to working in thickness units, although the appropriate call to convert_thickness does still occur within MOM_temp_salt_initialize_from_Z and the units of its arguments are not changed. The routine convert thickness was modified to work with a new input depth space input thickness argument and return a thickness in thickness units, and it is now being called after all of the routines to initialize thicknesses and temperatures and salinities, except in the few cases where the thickness are being specified directly in mass-based thickness units, as might happen when they are read from an input file. The new option "mass_file" is now a recognized option for the THICKNESS_CONFIG runtime parameter, and this information is passed in the new mass_file argument to initialize_thickness_from_file. The description of the runtime parameter THICKNESS_IC_RESCALE was updated to reflect this change. The unused thickness (h) argument to soliton_initialize_velocity was eliminated. The unused thickness (h) argument to determine_temperature was eliminated, as was the unused optional h_massless argument to the same function. This commit also rearranges the calls to do adjustments to the thicknesses to account for the presence of an ice shelf or to iteratively apply the ALE remapping to occur before the velocities are initialized, so that there is a clearer separation of the phases of the initialization. Also added optional height_units argument to ALE_initThicknessToCoord to specify that the coordinate are to be returned in height_units. If it is omitted or false, the previous thickness units are returned, but when called from MOM_initialize_state the new argument is being used. The runtime parameter CONVERT_THICKNESS_UNITS is no longer meaningful, so it has been obsoleted. All answers are bitwise identical, but there are multiple changes to the arguments to publicly visible subroutines or their units, and there are changes to the contents of the MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 12 +- src/diagnostics/MOM_obsolete_params.F90 | 1 + .../MOM_state_initialization.F90 | 304 ++++++++++-------- src/tracer/MOM_tracer_Z_init.F90 | 17 +- src/user/DOME2d_initialization.F90 | 36 +-- src/user/DOME_initialization.F90 | 6 +- src/user/ISOMIP_initialization.F90 | 26 +- src/user/Neverworld_initialization.F90 | 14 +- src/user/Phillips_initialization.F90 | 6 +- src/user/Rossby_front_2d_initialization.F90 | 14 +- src/user/SCM_CVMix_tests.F90 | 4 +- src/user/adjustment_initialization.F90 | 18 +- src/user/baroclinic_zone_initialization.F90 | 6 +- src/user/benchmark_initialization.F90 | 10 +- src/user/circle_obcs_initialization.F90 | 18 +- src/user/dense_water_initialization.F90 | 6 +- src/user/dumbbell_initialization.F90 | 18 +- src/user/external_gwave_initialization.F90 | 4 +- src/user/lock_exchange_initialization.F90 | 4 +- src/user/seamount_initialization.F90 | 18 +- src/user/sloshing_initialization.F90 | 6 +- src/user/soliton_initialization.F90 | 7 +- src/user/user_initialization.F90 | 7 +- 23 files changed, 295 insertions(+), 267 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index e40bba3e2f..a341fd1835 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1463,17 +1463,23 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) end subroutine ALE_writeCoordinateFile !> Set h to coordinate values for fixed coordinate systems -subroutine ALE_initThicknessToCoord( CS, G, GV, h ) +subroutine ALE_initThicknessToCoord( CS, G, GV, h, height_units ) type(ALE_CS), intent(inout) :: CS !< module control structure type(ocean_grid_type), intent(in) :: G !< module grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness in thickness units + !! [H ~> m or kg m-2] or height units [Z ~> m] + logical, optional, intent(in) :: height_units !< If present and true, the + !! thicknesses are in height units ! Local variables + real :: scale ! A scaling value for the thicknesses [nondim] or [H Z-1 ~> nondim or kg m-3] integer :: i, j + scale = GV%Z_to_H + if (present(height_units)) then ; if (height_units) scale = 1.0 ; endif do j = G%jsd,G%jed ; do i = G%isd,G%ied - h(i,j,:) = GV%Z_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j)+G%Z_ref ) + h(i,j,:) = scale * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j)+G%Z_ref ) enddo ; enddo end subroutine ALE_initThicknessToCoord diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 7564137de8..21a09dfdbb 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -56,6 +56,7 @@ subroutine find_obsolete_params(param_file) hint="Instead use OBC_SEGMENT_xxx_VELOCITY_NUDGING_TIMESCALES.") enddo + call obsolete_logical(param_file, "CONVERT_THICKNESS_UNITS", .true.) call obsolete_logical(param_file, "MASK_MASSLESS_TRACERS", .false.) call obsolete_logical(param_file, "SALT_REJECT_BELOW_ML", .false.) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index fccb47e69f..45285c2e05 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -150,7 +150,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & optional, intent(in) :: mass_shelf !< The mass per unit area of the overlying !! ice shelf [ R Z ~> kg m-2 ] ! Local variables - real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] + real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The layer thicknesses in geopotential (z) units [Z ~> m] character(len=200) :: inputdir ! The directory where NetCDF input files are. character(len=200) :: config real :: H_rescale ! A rescaling factor for thicknesses from the representation in @@ -224,6 +225,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & !do k=1,nz ; do j=js,je ; do i=is,ie ! h(i,j,k) = 0. !enddo + + ! Initialize the layer thicknesses. + dz(:,:,:) = 0.0 endif ! Set the nominal depth of the ocean, which might be different from the bathymetric @@ -248,6 +252,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "salinities from a Z-space file on a latitude-longitude grid.", & default=.false., do_not_log=just_read) + convert = new_sim ! Thicknesses are initialized in height units in most cases. if (from_Z_file) then ! Initialize thickness and T/S from z-coordinate data in a file. if (.NOT.use_temperature) call MOM_error(FATAL,"MOM_initialize_state : "//& @@ -255,14 +260,18 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, & just_read=just_read, frac_shelf_h=frac_shelf_h) + convert = .false. else ! Initialize thickness, h. call get_param(PF, mdl, "THICKNESS_CONFIG", config, & "A string that determines how the initial layer "//& "thicknesses are specified for a new run: \n"//& " \t file - read interface heights from the file specified \n"//& + " \t\t by (THICKNESS_FILE).\n"//& " \t thickness_file - read thicknesses from the file specified \n"//& " \t\t by (THICKNESS_FILE).\n"//& + " \t mass_file - read thicknesses in units of mass per unit area from the file \n"//& + " \t\t specified by (THICKNESS_FILE).\n"//& " \t coord - determined by ALE coordinate.\n"//& " \t uniform - uniform thickness layers evenly distributed \n"//& " \t\t between the surface and MAXIMUM_DEPTH. \n"//& @@ -287,51 +296,57 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & default="uniform", do_not_log=just_read) select case (trim(config)) case ("file") - call initialize_thickness_from_file(h, depth_tot, G, GV, US, PF, .false., just_read=just_read) + call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.false., & + mass_file=.false., just_read=just_read) case ("thickness_file") - call initialize_thickness_from_file(h, depth_tot, G, GV, US, PF, .true., just_read=just_read) + call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.true., & + mass_file=.false., just_read=just_read) + case ("mass_file") + call initialize_thickness_from_file(h, depth_tot, G, GV, US, PF, file_has_thickness=.true., & + mass_file=.true., just_read=just_read) + convert = .false. case ("coord") if (new_sim .and. useALE) then - call ALE_initThicknessToCoord( ALE_CSp, G, GV, h ) + call ALE_initThicknessToCoord( ALE_CSp, G, GV, dz, height_units=.true. ) elseif (new_sim) then call MOM_error(FATAL, "MOM_initialize_state: USE_REGRIDDING must be True "//& "for THICKNESS_CONFIG of 'coord'") endif - case ("uniform"); call initialize_thickness_uniform(h, depth_tot, G, GV, PF, & + case ("uniform"); call initialize_thickness_uniform(dz, depth_tot, G, GV, PF, & just_read=just_read) - case ("list"); call initialize_thickness_list(h, depth_tot, G, GV, US, PF, & + case ("list"); call initialize_thickness_list(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("DOME"); call DOME_initialize_thickness(h, depth_tot, G, GV, PF, & + case ("DOME"); call DOME_initialize_thickness(dz, depth_tot, G, GV, PF, & just_read=just_read) - case ("ISOMIP"); call ISOMIP_initialize_thickness(h, depth_tot, G, GV, US, PF, tv, & + case ("ISOMIP"); call ISOMIP_initialize_thickness(dz, depth_tot, G, GV, US, PF, tv, & just_read=just_read) - case ("benchmark"); call benchmark_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("benchmark"); call benchmark_initialize_thickness(dz, depth_tot, G, GV, US, PF, & tv%eqn_of_state, tv%P_Ref, just_read=just_read) - case ("Neverworld","Neverland"); call Neverworld_initialize_thickness(h, depth_tot, & + case ("Neverworld","Neverland"); call Neverworld_initialize_thickness(dz, depth_tot, & G, GV, US, PF, tv%P_Ref) case ("search"); call initialize_thickness_search() - case ("circle_obcs"); call circle_obcs_initialize_thickness(h, depth_tot, G, GV, PF, & + case ("circle_obcs"); call circle_obcs_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, US, & + case ("lock_exchange"); call lock_exchange_initialize_thickness(dz, G, GV, US, & PF, just_read=just_read) - case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, US, & + case ("external_gwave"); call external_gwave_initialize_thickness(dz, G, GV, US, & PF, just_read=just_read) - case ("DOME2D"); call DOME2d_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("DOME2D"); call DOME2d_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("adjustment2d"); call adjustment_initialize_thickness(h, G, GV, US, & + case ("adjustment2d"); call adjustment_initialize_thickness(dz, G, GV, US, & PF, just_read=just_read) - case ("sloshing"); call sloshing_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("sloshing"); call sloshing_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("seamount"); call seamount_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("seamount"); call seamount_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("dumbbell"); call dumbbell_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("dumbbell"); call dumbbell_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("soliton"); call soliton_initialize_thickness(h, depth_tot, G, GV, US) - case ("phillips"); call Phillips_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("soliton"); call soliton_initialize_thickness(dz, depth_tot, G, GV, US) + case ("phillips"); call Phillips_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, US, & + case ("rossby_front"); call Rossby_front_initialize_thickness(dz, G, GV, US, & PF, just_read=just_read) - case ("USER"); call user_initialize_thickness(h, G, GV, PF, & + case ("USER"); call user_initialize_thickness(dz, G, GV, PF, & just_read=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized layer thickness configuration "//trim(config)) @@ -372,26 +387,26 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & G, GV, US, PF, just_read=just_read) case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, GV, US, PF, & just_read=just_read) - case ("DOME2D"); call DOME2d_initialize_temperature_salinity (tv%T, tv%S, h, & + case ("DOME2D"); call DOME2d_initialize_temperature_salinity (tv%T, tv%S, dz, & G, GV, US, PF, just_read=just_read) - case ("ISOMIP"); call ISOMIP_initialize_temperature_salinity (tv%T, tv%S, h, & + case ("ISOMIP"); call ISOMIP_initialize_temperature_salinity (tv%T, tv%S, dz, & depth_tot, G, GV, US, PF, eos, just_read=just_read) case ("adjustment2d"); call adjustment_initialize_temperature_salinity ( tv%T, & - tv%S, h, depth_tot, G, GV, US, PF, just_read=just_read) + tv%S, dz, depth_tot, G, GV, US, PF, just_read=just_read) case ("baroclinic_zone"); call baroclinic_zone_init_temperature_salinity( tv%T, & - tv%S, h, depth_tot, G, GV, US, PF, just_read=just_read) + tv%S, dz, depth_tot, G, GV, US, PF, just_read=just_read) case ("sloshing"); call sloshing_initialize_temperature_salinity(tv%T, & - tv%S, h, G, GV, US, PF, just_read=just_read) + tv%S, dz, G, GV, US, PF, just_read=just_read) case ("seamount"); call seamount_initialize_temperature_salinity(tv%T, & - tv%S, h, G, GV, US, PF, just_read=just_read) + tv%S, dz, G, GV, US, PF, just_read=just_read) case ("dumbbell"); call dumbbell_initialize_temperature_salinity(tv%T, & - tv%S, h, G, GV, US, PF, just_read=just_read) + tv%S, dz, G, GV, US, PF, just_read=just_read) case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, GV, US, PF, just_read=just_read) - case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init(tv%T, tv%S, h, & + tv%S, dz, G, GV, US, PF, just_read=just_read) + case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init(tv%T, tv%S, dz, & G, GV, US, PF, just_read=just_read) case ("dense"); call dense_water_initialize_TS(G, GV, US, PF, tv%T, tv%S, & - h, just_read=just_read) + dz, just_read=just_read) case ("USER"); call user_init_temperature_salinity(tv%T, tv%S, G, GV, PF, & just_read=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& @@ -402,8 +417,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (use_temperature .and. use_OBC) & call fill_temp_salt_segments(G, GV, US, OBC, tv) - ! Calculate the initial surface displacement under ice shelf + ! Convert thicknesses from geometric distances in depth units to thickness units or mass-per-unit-area. + if (new_sim .and. convert) call convert_thickness(dz, h, G, GV, US, tv) + ! Handle the initial surface displacement under ice shelf call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & "If true, depress the initial surface to avoid huge "//& "tsunamis when a large surface pressure is applied.", & @@ -413,10 +430,43 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "at the depth where the hydrostatic pressure matches the imposed "//& "surface pressure which is read from file.", default=.false., & do_not_log=just_read) + if (depress_sfc .and. trim_ic_for_p_surf) call MOM_error(FATAL, "MOM_initialize_state: "//& + "DEPRESS_INITIAL_SURFACE and TRIM_IC_FOR_P_SURF are exclusive and cannot both be True") - if (new_sim) then - if (use_ice_shelf .and. present(mass_shelf) .and. .not. (trim_ic_for_p_surf .or. depress_sfc)) & - call calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h) + if (new_sim .and. debug .and. (depress_sfc .or. trim_ic_for_p_surf)) & + call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + + ! Remove the mass that would be displaced by an ice shelf or inverse barometer. + if (depress_sfc) then + call depress_surface(h, G, GV, US, PF, tv, just_read=just_read) + elseif (trim_ic_for_p_surf) then + call trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read=just_read) + elseif (new_sim .and. use_ice_shelf .and. present(mass_shelf)) then + call calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h) + endif + + ! Perhaps we want to run the regridding coordinate generator for multiple + ! iterations here so the initial grid is consistent with the coordinate + if (useALE) then + call get_param(PF, mdl, "REGRID_ACCELERATE_INIT", regrid_accelerate, & + "If true, runs REGRID_ACCELERATE_ITERATIONS iterations of the regridding "//& + "algorithm to push the initial grid to be consistent with the initial "//& + "condition. Useful only for state-based and iterative coordinates.", & + default=.false., do_not_log=just_read) + if (regrid_accelerate) then + call get_param(PF, mdl, "REGRID_ACCELERATE_ITERATIONS", regrid_iterations, & + "The number of regridding iterations to perform to generate "//& + "an initial grid that is consistent with the initial conditions.", & + default=1, do_not_log=just_read) + + call get_param(PF, mdl, "DT", dt, "Timestep", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) + + if (new_sim .and. debug) & + call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) + call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & + dt=dt, initial=.true.) + endif endif ! The thicknesses in halo points might be needed to initialize the velocities. @@ -436,21 +486,15 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t USER - call a user modified routine.", default="zero", & do_not_log=just_read) select case (trim(config)) - case ("file"); call initialize_velocity_from_file(u, v, G, GV, US, PF, & - just_read=just_read) - case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, & - just_read=just_read) - case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, & - just_read=just_read) - case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, & - just_read=just_read) - case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, & - just_read=just_read) + case ("file"); call initialize_velocity_from_file(u, v, G, GV, US, PF, just_read) + case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, just_read) + case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, just_read) + case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, just_read) + case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, just_read) case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & - G, GV, US, PF, just_read=just_read) - case ("soliton"); call soliton_initialize_velocity(u, v, h, G, GV, US) - case ("USER"); call user_initialize_velocity(u, v, G, GV, US, PF, & - just_read=just_read) + G, GV, US, PF, just_read) + case ("soliton"); call soliton_initialize_velocity(u, v, G, GV, US) + case ("USER"); call user_initialize_velocity(u, v, G, GV, US, PF, just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized velocity configuration "//trim(config)) end select @@ -460,49 +504,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) endif - ! Optionally convert the thicknesses from m to kg m-2. This is particularly - ! useful in a non-Boussinesq model. - call get_param(PF, mdl, "CONVERT_THICKNESS_UNITS", convert, & - "If true, convert the thickness initial conditions from "//& - "units of m to kg m-2 or vice versa, depending on whether "//& - "BOUSSINESQ is defined. This does not apply if a restart "//& - "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) - - if (new_sim .and. convert .and. .not.GV%Boussinesq) & - ! Convert thicknesses from geometric distances to mass-per-unit-area. - call convert_thickness(h, G, GV, US, tv) - - ! Remove the mass that would be displaced by an ice shelf or inverse barometer. - if (depress_sfc .and. trim_ic_for_p_surf) call MOM_error(FATAL, "MOM_initialize_state: "//& - "DEPRESS_INITIAL_SURFACE and TRIM_IC_FOR_P_SURF are exclusive and cannot both be True") - if (new_sim .and. debug .and. (depress_sfc .or. trim_ic_for_p_surf)) & - call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, scale=GV%H_to_m) - if (depress_sfc) call depress_surface(h, G, GV, US, PF, tv, just_read=just_read) - if (trim_ic_for_p_surf) call trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read=just_read) - - ! Perhaps we want to run the regridding coordinate generator for multiple - ! iterations here so the initial grid is consistent with the coordinate - if (useALE) then - call get_param(PF, mdl, "REGRID_ACCELERATE_INIT", regrid_accelerate, & - "If true, runs REGRID_ACCELERATE_ITERATIONS iterations of the regridding "//& - "algorithm to push the initial grid to be consistent with the initial "//& - "condition. Useful only for state-based and iterative coordinates.", & - default=.false., do_not_log=just_read) - if (regrid_accelerate) then - call get_param(PF, mdl, "REGRID_ACCELERATE_ITERATIONS", regrid_iterations, & - "The number of regridding iterations to perform to generate "//& - "an initial grid that is consistent with the initial conditions.", & - default=1, do_not_log=just_read) - - call get_param(PF, mdl, "DT", dt, "Timestep", & - units="s", scale=US%s_to_T, fail_if_missing=.true.) - - if (new_sim .and. debug) & - call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_m) - call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & - dt=dt, initial=.true.) - endif - endif + ! This is the end of the block of code that might have initialized fields + ! internally at the start of a new run. ! Initialized assimilative incremental update (oda_incupd) structure and ! register restart. @@ -515,9 +518,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call restart_registry_lock(restart_CS) endif - ! This is the end of the block of code that might have initialized fields - ! internally at the start of a new run. - if (.not.new_sim) then ! This block restores the state from a restart file. ! This line calls a subroutine that reads the initial conditions ! from a previously generated file. @@ -536,7 +536,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call pass_var(h, G%Domain) if (debug) then - call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, scale=US%C_to_degC) if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, scale=US%S_to_ppt) if ( use_temperature .and. debug_layers) then ; do k=1,nz @@ -655,12 +655,14 @@ end subroutine MOM_initialize_state !> Reads the layer thicknesses or interface heights from a file. subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, file_has_thickness, & - just_read) + just_read, mass_file) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized, in height + !! or thickness units, depending on the value of + !! mass_file [Z ~> m] or [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -670,6 +672,8 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f !! interface heights. logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. + logical, intent(in) :: mass_file !< If true, this file contains layer thicknesses in + !! units of mass per unit area. ! Local variables real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, in depth units [Z ~> m]. @@ -711,12 +715,17 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f "The variable name for layer thickness initial conditions.", & default="h", do_not_log=just_read) call get_param(param_file, mdl, "THICKNESS_IC_RESCALE", h_rescale, & - "A factor by which to rescale the initial thicknesses in the input "//& - "file to convert them to units of m.", & + 'A factor by which to rescale the initial thicknesses in the input file to '//& + 'convert them to units of kg/m2 (if THICKNESS_CONFIG="mass_file") or m.', & default=1.0, units="various", do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=h_rescale*GV%m_to_H) + if (mass_file) then + h_rescale = h_rescale*GV%kg_m2_to_H + else + h_rescale = h_rescale*US%m_to_Z + endif + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=h_rescale) else call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & "If true, all mass below the bottom removed if the "//& @@ -751,9 +760,9 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta(i,j,K) - eta(i,j,K+1)) + h(i,j,k) = eta(i,j,K) - eta(i,j,K+1) endif enddo ; enddo ; enddo @@ -786,7 +795,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: eta !< Interface heights [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [Z ~> m] real, intent(in) :: ht !< Tolerance to exceed adjustment !! criteria [Z ~> m] real, optional, intent(in) :: dZ_ref_eta !< The difference between the @@ -845,10 +854,6 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) endif enddo ; enddo - ! Now convert thicknesses to units of H. - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k)*GV%Z_to_H - enddo ; enddo ; enddo call sum_across_PEs(dilations) if ((dilations > 0) .and. (is_root_pe())) then @@ -864,7 +869,7 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -903,9 +908,9 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo @@ -917,9 +922,9 @@ end subroutine initialize_thickness_uniform subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -978,9 +983,9 @@ subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_r eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo @@ -993,14 +998,17 @@ subroutine initialize_thickness_search call MOM_error(FATAL," MOM_state_initialization.F90, initialize_thickness_search: NOT IMPLEMENTED") end subroutine initialize_thickness_search -!> Converts thickness from geometric to pressure units -subroutine convert_thickness(h, G, GV, US, tv) +!> Converts thickness from geometric height units to thickness units +subroutine convert_thickness(dz, h, G, GV, US, tv) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Input geometric layer thicknesses being converted - !! to layer pressure [H ~> m or kg m-2]. + intent(in) :: dz !< Input geometric layer thicknesses [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initalized values in halo points. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables ! Local variables @@ -1010,8 +1018,6 @@ subroutine convert_thickness(h, G, GV, US, tv) real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] real :: I_gEarth ! Unit conversion factors divided by the gravitational acceleration ! [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] - real :: HR_to_pres ! A conversion factor from the input geometric thicknesses times the layer - ! densities into pressure units [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: itt, max_itt @@ -1021,10 +1027,11 @@ subroutine convert_thickness(h, G, GV, US, tv) max_itt = 10 if (GV%Boussinesq) then - call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo else I_gEarth = GV%RZ_to_H / GV%g_Earth - HR_to_pres = GV%g_Earth * GV%H_to_Z if (associated(tv%eqn_of_state)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1037,7 +1044,8 @@ subroutine convert_thickness(h, G, GV, US, tv) call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & tv%eqn_of_state, EOSdom) do i=is,ie - p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(i,j,k) * rho(i)) + ! This could be simplified, but it would change answers at roundoff. + p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) enddo enddo @@ -1050,7 +1058,7 @@ subroutine convert_thickness(h, G, GV, US, tv) ! Use Newton's method to correct the bottom value. ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * (HR_to_pres*h(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) enddo enddo ; endif enddo @@ -1061,7 +1069,7 @@ subroutine convert_thickness(h, G, GV, US, tv) enddo else do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) + h(i,j,k) = (GV%Z_to_H*dz(i,j,k)) * (GV%Rlay(k) / GV%Rho0) enddo ; enddo ; enddo endif endif @@ -2491,7 +2499,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just real, dimension(:,:,:), allocatable, target :: salt_z ! Input salinities [S ~> ppt] real, dimension(:,:,:), allocatable, target :: mask_z ! 1 for valid data points [nondim] real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Layer thicknesses in height units [Z ~> m] real, dimension(SZI_(G),SZJ_(G)) :: Z_bottom ! The (usually negative) height of the seafloor ! relative to the surface [Z ~> m]. integer, dimension(SZI_(G),SZJ_(G)) :: nlevs ! The number of levels in each column with valid data @@ -2502,7 +2511,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just real, dimension(:,:,:), allocatable, target :: tmpT1dIn ! Input temperatures on a model-sized grid [C ~> degC] real, dimension(:,:,:), allocatable, target :: tmpS1dIn ! Input salinities on a model-sized grid [S ~> ppt] real, dimension(:,:,:), allocatable :: tmp_mask_in ! The valid data mask on a model-sized grid [nondim] - real, dimension(:,:,:), allocatable :: h1 ! Thicknesses [H ~> m or kg m-2]. + real, dimension(:,:,:), allocatable :: dz1 ! Input grid thicknesses in depth units [Z ~> m] + real, dimension(:,:,:), allocatable :: h1 ! Thicknesses on the input grid [H ~> m or kg m-2]. real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to ! regridding [H ~> m or kg m-2] real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. @@ -2709,7 +2719,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just if ((.not.useALEremapping) .and. adjust_temperature) & ! This call is just here to read and log the determine_temperature parameters call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), eos, tv%P_Ref, 0, & - h, 0, G, GV, US, PF, just_read=.true.) + 0, G, GV, US, PF, just_read=.true.) call cpu_clock_end(id_clock_routine) return ! All run-time parameters have been read, so return. endif @@ -2761,6 +2771,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Build the source grid and copy data onto model-shaped arrays with vanished layers allocate( tmp_mask_in(isd:ied,jsd:jed,nkd), source=0.0 ) + allocate( dz1(isd:ied,jsd:jed,nkd), source=0.0 ) allocate( h1(isd:ied,jsd:jed,nkd), source=0.0 ) allocate( tmpT1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) allocate( tmpS1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) @@ -2781,10 +2792,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just tmpT1dIn(i,j,k) = temp_land_fill tmpS1dIn(i,j,k) = salt_land_fill endif - h1(i,j,k) = GV%Z_to_H * (zTopOfCell - zBottomOfCell) + dz1(i,j,k) = (zTopOfCell - zBottomOfCell) zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - h1(i,j,kd) = h1(i,j,kd) + GV%Z_to_H * max(0., zTopOfCell - Z_bottom(i,j) ) + dz1(i,j,kd) = dz1(i,j,kd) + max(0., zTopOfCell - Z_bottom(i,j) ) ! The max here is in case the data data is shallower than model endif ! mask2dT enddo ; enddo @@ -2799,20 +2810,27 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just allocate( hTarget(nz) ) hTarget = getCoordinateResolution( regridCS ) do j = js, je ; do i = is, ie - h(i,j,:) = 0. + dz(i,j,:) = 0. if (G%mask2dT(i,j) > 0.) then ! Build the target grid combining hTarget and topography zTopOfCell = 0. ; zBottomOfCell = 0. do k = 1, nz zBottomOfCell = max( zTopOfCell - hTarget(k), Z_bottom(i,j)) - h(i,j,k) = GV%Z_to_H * (zTopOfCell - zBottomOfCell) + dz(i,j,k) = zTopOfCell - zBottomOfCell zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo else - h(i,j,:) = 0. + dz(i,j,:) = 0. endif ! mask2dT enddo ; enddo deallocate( hTarget ) + + do k=1,nkd ; do j=js,je ; do i=is,ie + h1(i,j,k) = GV%Z_to_H*dz1(i,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H*dz(i,j,k) + enddo ; enddo ; enddo endif ! Now remap from source grid to target grid, first setting reconstruction parameters @@ -2826,6 +2844,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just GV_loc%ke = nkd allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used + ! Convert thicknesses to units of H. + call convert_thickness(dz1, h1, G, GV_loc, US, tv_loc) + call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, & @@ -2838,6 +2859,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & old_remap=remap_old_alg, answer_date=remap_answer_date ) + deallocate( dz1 ) deallocate( h1 ) deallocate( tmpT1dIn ) deallocate( tmpS1dIn ) @@ -2874,15 +2896,16 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just deallocate(rho_z) + dz(:,:,:) = 0.0 if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, US, zi, h, h_tolerance, dZ_ref_eta=G%Z_ref) + call adjustEtaToFitBathymetry(G, GV, US, zi, dz, h_tolerance, dZ_ref_eta=G%Z_ref) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_Z)) then zi(i,j,K) = zi(i,j,K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (zi(i,j,K) - zi(i,j,K+1)) + dz(i,j,k) = zi(i,j,K) - zi(i,j,K+1) endif enddo ; enddo ; enddo inconsistent = 0 @@ -2914,9 +2937,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Finally adjust to target density ks = 1 ; if (separate_mixed_layer) ks = GV%nk_rho_varies + 1 call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), eos, tv%P_Ref, niter, & - h, ks, G, GV, US, PF, just_read) + ks, G, GV, US, PF, just_read) endif + ! Now convert thicknesses to units of H. + call convert_thickness(dz, h, G, GV, US, tv) + endif ! useALEremapping deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index c089181c16..fab7da3917 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -556,8 +556,8 @@ end function find_limited_slope !> This subroutine determines the potential temperature and salinity that !! is consistent with the target density using provided initial guess -subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, h, k_start, G, GV, US, & - PF, just_read, h_massless) +subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, G, GV, US, PF, & + just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -565,20 +565,15 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, h, k_star real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: salt !< salinity [S ~> ppt] real, dimension(SZK_(GV)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. - type(EOS_type), intent(in) :: EOS !< seawater equation of state control structure + type(EOS_type), intent(in) :: EOS !< seawater equation of state control structure real, intent(in) :: p_ref !< reference pressure [R L2 T-2 ~> Pa]. integer, intent(in) :: niter !< maximum number of iterations integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< layer thickness, used only to avoid working on - !! massless layers [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing T or S. - real, optional, intent(in) :: h_massless !< A threshold below which a layer is - !! determined to be massless [H ~> m or kg m-2] ! Local variables (All of which need documentation!) real, dimension(SZI_(G),SZK_(GV)) :: & @@ -587,7 +582,6 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, h, k_star dT, & ! An estimated change in temperature before bounding [C ~> degC] dS, & ! An estimated change in salinity before bounding [S ~> ppt] rho, & ! Layer densities with the current estimate of temperature and salinity [R ~> kg m-3] - hin, & ! A 2D copy of the layer thicknesses [H ~> m or kg m-2] drho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] drho_dS ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G)) :: press ! Reference pressures [R L2 T-2 ~> Pa] @@ -675,7 +669,6 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, h, k_star dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... T(:,:) = temp(:,j,:) S(:,:) = salt(:,j,:) - hin(:,:) = h(:,j,:) dT(:,:) = 0.0 adjust_salt = .true. iter_loop: do itt = 1,niter @@ -685,7 +678,7 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, h, k_star EOS, EOSdom ) enddo do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln) then +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then if (abs(rho(i,k)-R_tgt(k))>tol_rho) then if (.not.fit_together) then dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) @@ -713,7 +706,7 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, h, k_star EOS, EOSdom ) enddo do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 1382fe8e34..5cc63e734f 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -98,7 +98,7 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -158,16 +158,16 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom_H - h(i,j,nz) = GV%Z_to_H * dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_H + h(i,j,1:nz-1) = GV%Angstrom_Z + h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z endif enddo ; enddo @@ -180,16 +180,16 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju ! eta1D(k) = e0(k) ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then ! eta1D(k) = eta1D(k+1) + min_thickness - ! h(i,j,k) = GV%Z_to_H * min_thickness + ! h(i,j,k) = min_thickness ! else - ! h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + ! h(i,j,k) = eta1D(k) - eta1D(k+1) ! endif ! enddo ! ! x = G%geoLonT(i,j) / G%len_lon ! if ( x <= dome2d_width_bay ) then - ! h(i,j,1:nz-1) = GV%Z_to_H * min_thickness - ! h(i,j,nz) = GV%Z_to_H * (dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness) + ! h(i,j,1:nz-1) = min_thickness + ! h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness ! endif ! ! enddo ; enddo @@ -202,16 +202,16 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo case ( REGRIDDING_SIGMA ) do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H*depth_tot(i,j) / nz + h(i,j,:) = depth_tot(i,j) / nz enddo ; enddo case default @@ -225,11 +225,11 @@ end subroutine DOME2d_initialize_thickness !> Initialize temperature and salinity in the 2d DOME configuration subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, just_read) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: just_read !< If true, this call will @@ -287,7 +287,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth + xi1 = xi0 + h(i,j,k) / G%max_depth S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo @@ -298,7 +298,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth + xi1 = xi0 + h(i,j,k) / G%max_depth S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 7f939ffef6..4a12387d9d 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -105,7 +105,7 @@ subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -141,9 +141,9 @@ subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index bba357f490..7e3299b372 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -143,7 +143,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -170,7 +170,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") + call MOM_mesg("ISOMIP_initialization.F90, ISOMIP_initialize_thickness: setting thickness") call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & 'Minimum layer thickness', units='m', default=1.e-3, do_not_log=just_read, scale=US%m_to_Z) @@ -225,9 +225,9 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -240,9 +240,9 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -250,7 +250,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) + h(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo case default @@ -269,7 +269,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The nominal total bottom-to-top !! depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure @@ -334,10 +334,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U do j=js,je ; do i=is,ie xi0 = -depth_tot(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth in middle of layer + xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer S(i,j,k) = S_sur + dS_dz * xi0 T(i,j,k) = T_sur + dT_dz * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth at top of layer + xi0 = xi0 + 0.5 * h(i,j,k) ! Depth at top of layer enddo enddo ; enddo @@ -372,10 +372,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U xi0 = 0.0 do k = 1,nz !T0(k) = T_Ref; S0(k) = S_Ref - xi1 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z + xi1 = xi0 + 0.5 * h(i,j,k) S0(k) = S_sur - dS_dz * xi1 T0(k) = T_sur - dT_dz * xi1 - xi0 = xi0 + h(i,j,k) * GV%H_to_Z + xi0 = xi0 + h(i,j,k) ! write(mesg,*) 'S,T,xi0,xi1,k',S0(k),T0(k),xi0,xi1,k ! call MOM_mesg(mesg,5) enddo @@ -430,7 +430,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U !i=G%iec; j=G%jec !do k = 1,nz ! call calculate_density(T(i,j,k), S(i,j,k),0.0,rho_tmp,eqn_of_state, scale=US%kg_m3_to_R) - ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),US%C_to_degC*T(i,j,k),US%S_to_ppt*S(i,j,k),rho_tmp,GV%Rlay(k) + ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,US%Z_to_m*h(i,j,k),US%C_to_degC*T(i,j,k),US%S_to_ppt*S(i,j,k),rho_tmp,GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index fcd40cf8da..05de663d46 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -243,7 +243,7 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< The thickness that is being - !! initialized [H ~> m or kg m-2]. + !! initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open @@ -288,12 +288,12 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, do j=js,je ; do i=is,ie e_interface = -depth_tot(i,j) do k=nz,2,-1 - h(i,j,k) = GV%Z_to_H * (e0(k) - e_interface) ! Nominal thickness + h(i,j,k) = e0(k) - e_interface ! Nominal thickness x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat r1 = sqrt((x-0.7)**2+(y-0.2)**2) r2 = sqrt((x-0.3)**2+(y-0.25)**2) - h(i,j,k) = h(i,j,k) + pert_amp * (e0(k) - e0(nz+1)) * GV%Z_to_H * & + h(i,j,k) = h(i,j,k) + pert_amp * (e0(k) - e0(nz+1)) * & (spike(r1,0.15)-spike(r2,0.15)) ! Prescribed perturbation if (h_noise /= 0.) then rns = initializeRandomNumberStream( int( 4096*(x + (y+1.)) ) ) @@ -301,11 +301,11 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, noise = h_noise * 2. * ( noise - 0.5 ) ! range -h_noise to h_noise h(i,j,k) = ( 1. + noise ) * h(i,j,k) endif - h(i,j,k) = max( GV%Angstrom_H, h(i,j,k) ) ! Limit to non-negative - e_interface = e_interface + GV%H_to_Z * h(i,j,k) ! Actual position of upper interface + h(i,j,k) = max( GV%Angstrom_Z, h(i,j,k) ) ! Limit to non-negative + e_interface = e_interface + h(i,j,k) ! Actual position of upper interface enddo - h(i,j,1) = GV%Z_to_H * (e0(1) - e_interface) ! Nominal thickness - h(i,j,1) = max( GV%Angstrom_H, h(i,j,1) ) ! Limit to non-negative + h(i,j,1) = e0(1) - e_interface ! Nominal thickness + h(i,j,1) = max( GV%Angstrom_Z, h(i,j,1) ) ! Limit to non-negative enddo ; enddo end subroutine Neverworld_initialize_thickness diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 62b55bb0a1..e0d2cafeae 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -39,7 +39,7 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2] + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -116,9 +116,9 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju eta1D(K) = eta_im(j,K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 9ff99b583f..4f213d86d9 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -40,7 +40,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2] + intent(out) :: h !< The thickness that is being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read @@ -83,7 +83,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz - h(i,j,k) = h0 * GV%Z_to_H + h(i,j,k) = h0 enddo enddo ; enddo @@ -94,7 +94,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz - h(i,j,k) = h0 * GV%Z_to_H + h(i,j,k) = h0 enddo enddo ; enddo @@ -114,7 +114,7 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle logical, intent(in) :: just_read !< If true, this call will @@ -125,7 +125,7 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] real :: T_range ! Range of temperatures over the vertical [C ~> degC] real :: zc ! Position of the middle of the cell [Z ~> m] - real :: zi ! Bottom interface position relative to the sea surface [H ~> m or kg m-2] + real :: zi ! Bottom interface position relative to the sea surface [Z ~> m] real :: dTdz ! Vertical temperature gradient [C Z-1 ~> degC m-1] character(len=40) :: verticalCoordinate @@ -149,8 +149,8 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & do j = G%jsc,G%jec ; do i = G%isc,G%iec zi = 0. do k = 1, nz - zi = zi - h(i,j,k) ! Bottom interface position - zc = GV%H_to_Z * (zi - 0.5*h(i,j,k)) ! Position of middle of cell + zi = zi - h(i,j,k) ! Bottom interface position + zc = zi - 0.5*h(i,j,k) ! Position of middle of cell zc = min( zc, -Hml(G, G%geoLatT(i,j)) ) ! Bound by depth of mixed layer T(i,j,k) = T_ref + dTdz * zc ! Linear temperature profile enddo diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 8df8f90e3d..7b1b4b3946 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -57,7 +57,7 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Input parameter structure logical, intent(in) :: just_read !< If present and true, this call @@ -108,7 +108,7 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) top = 0. ! Reference to surface bottom = 0. do k=1,nz - bottom = bottom - h(i,j,k)*GV%H_to_Z ! Interface below layer [Z ~> m] + bottom = bottom - h(i,j,k) ! Interface below layer [Z ~> m] zC = 0.5*( top + bottom ) ! Z of middle of layer [Z ~> m] DZ = min(0., zC + UpperLayerTempMLD) T(i,j,k) = max(LowerLayerMinTemp,LowerLayerTemp + LowerLayerdTdZ * DZ) diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index a958ebdebb..58389b7b5c 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -36,7 +36,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read @@ -71,7 +71,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("initialize_thickness_uniform: setting thickness") + call MOM_mesg("adjustment_initialize_thickness: setting thickness") ! Parameters used by main model initialization if (.not.just_read) call log_version(param_file, mdl, version, "") @@ -170,12 +170,12 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read do k=nz,1,-1 if (eta1D(k) > 0.) then eta1D(k) = max( eta1D(k+1) + min_thickness, 0. ) - h(i,j,k) = GV%Z_to_H * max( eta1D(k) - eta1D(k+1), min_thickness ) + h(i,j,k) = max( eta1D(k) - eta1D(k+1), min_thickness ) elseif (eta1D(k) <= (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -187,7 +187,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read enddo do j=js,je ; do i=is,ie do k=nz,1,-1 - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) enddo enddo ; enddo @@ -209,7 +209,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: S !< The salinity that is being initialized [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< The model thicknesses [H ~> m or kg m-2]. + intent(in) :: h !< The model thicknesses [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to @@ -275,7 +275,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, do j=js,je ; do i=is,ie eta1d(nz+1) = -depth_tot(i,j) do k=nz,1,-1 - eta1d(k) = eta1d(k+1) + h(i,j,k)*GV%H_to_Z + eta1d(k) = eta1d(k+1) + h(i,j,k) enddo if (front_wave_length /= 0.) then y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) @@ -296,7 +296,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, x = 1. - min(1., x) T(i,j,k) = T_range * x enddo - ! x = GV%H_to_Z*sum(T(i,j,:)*h(i,j,:)) + ! x = sum(T(i,j,:)*h(i,j,:)) ! T(i,j,:) = (T(i,j,:) / x) * (G%max_depth*1.5/real(nz)) enddo ; enddo diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index 2ff4e1ec80..e2c6182231 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -86,7 +86,7 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, depth_tot, G, GV, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: S !< Salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< The model thicknesses [H ~> m or kg m-2] + intent(in) :: h !< The model thicknesses [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -135,8 +135,8 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, depth_tot, G, GV, fn = xs endif do k = nz, 1, -1 - zc = zi + 0.5*h(i,j,k)*GV%H_to_Z ! Position of middle of cell - zi = zi + h(i,j,k)*GV%H_to_Z ! Top interface position + zc = zi + 0.5*h(i,j,k) ! Position of middle of cell + zi = zi + h(i,j,k) ! Top interface position T(i,j,k) = T_ref + dTdz * zc & ! Linear temperature stratification + dTdx * x & ! Linear gradient + delta_T * fn ! Smooth fn of width L_zone diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 3920b52729..333f53895e 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -84,7 +84,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -184,9 +184,9 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e do k=1,nz ; e_pert(K) = 0.0 ; enddo - ! This sets the initial thickness (in [H ~> m or kg m-2]) of the layers. The thicknesses + ! This sets the initial thickness (in [Z ~> m]) of the layers. The thicknesses ! are set to insure that: - ! 1. each layer is at least GV%Angstrom_H thick, and + ! 1. each layer is at least GV%Angstrom_Z thick, and ! 2. the interfaces are where they should be based on the resting depths and ! interface height perturbations, as long at this doesn't interfere with 1. eta1D(nz+1) = -depth_tot(i,j) @@ -211,9 +211,9 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e if (eta1D(K) < eta1D(K+1) + GV%Angstrom_Z) & eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = max(GV%Z_to_H * (eta1D(K) - eta1D(K+1)), GV%Angstrom_H) + h(i,j,k) = max(eta1D(K) - eta1D(K+1), GV%Angstrom_Z) enddo - h(i,j,1) = max(GV%Z_to_H * (0.0 - eta1D(2)), GV%Angstrom_H) + h(i,j,1) = max(0.0 - eta1D(2), GV%Angstrom_Z) enddo ; enddo diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 63c5c8a0d4..ab9ab385de 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -10,6 +10,7 @@ module circle_obcs_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -27,11 +28,12 @@ module circle_obcs_initialization contains !> This subroutine initializes layer thicknesses for the circle_obcs experiment. -subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. +subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -43,7 +45,7 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - real :: IC_amp ! The amplitude of the initial height displacement [H ~> m or kg m-2]. + real :: IC_amp ! The amplitude of the initial height displacement [Z ~> m]. real :: diskrad ! Radius of the elevated disk [km] or [degrees] or [m] real :: rad ! Distance from the center of the elevated disk [km] or [degrees] or [m] real :: lonC ! The x-position of a point [km] or [degrees] or [m] @@ -73,7 +75,7 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus call get_param(param_file, mdl, "DISK_IC_AMPLITUDE", IC_amp, & "Initial amplitude of interface height displacements "//& "in the circle_obcs test case.", & - units='m', default=5.0, scale=GV%m_to_H, do_not_log=just_read) + units='m', default=5.0, scale=US%m_to_Z, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -88,9 +90,9 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 81aa4c2b3b..6feb2bdda6 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -105,7 +105,7 @@ subroutine dense_water_initialize_TS(G, GV, US, param_file, T, S, h, just_read) type(param_file_type), intent(in) :: param_file !< Parameter file structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Output temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Output salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [Z ~> m] logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. ! Local variables @@ -137,7 +137,7 @@ subroutine dense_water_initialize_TS(G, GV, US, param_file, T, S, h, just_read) zi = 0. do k = 1,nz ! nondimensional middle of layer - zmid = zi + 0.5 * h(i,j,k) / (GV%Z_to_H * G%max_depth) + zmid = zi + 0.5 * h(i,j,k) / G%max_depth if (zmid < mld) then ! use reference salinity in the mixed layer @@ -147,7 +147,7 @@ subroutine dense_water_initialize_TS(G, GV, US, param_file, T, S, h, just_read) S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) endif - zi = zi + h(i,j,k) / (GV%Z_to_H * G%max_depth) + zi = zi + h(i,j,k) / G%max_depth enddo enddo enddo diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 0b65883eca..abd4f4f37e 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -96,7 +96,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -126,7 +126,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") + call MOM_mesg("dumbbell_initialization.F90, dumbbell_initialize_thickness: setting thickness") if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & @@ -174,7 +174,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, enddo endif do k=1,nz - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) enddo enddo enddo @@ -217,9 +217,9 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -232,9 +232,9 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -242,7 +242,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) + h(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo end select @@ -255,7 +255,7 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: just_read !< If true, this call will diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index 63cc89342a..437edc49b2 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -30,7 +30,7 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read @@ -73,7 +73,7 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re enddo eta1D(nz+1) = -G%max_depth ! Force bottom interface to bottom do k=1,nz - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) enddo enddo ; enddo diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index 3b41237c36..ab08d4068d 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -28,7 +28,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read @@ -80,7 +80,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea eta1D(K) = min( eta1D(K), eta1D(K-1) - GV%Angstrom_Z ) enddo do k=nz,1,-1 - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) enddo enddo ; enddo diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index a1f978a784..d1971f25f9 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -84,7 +84,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -105,7 +105,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") + call MOM_mesg("seamount_initialization.F90, seamount_initialize_thickness: setting thickness") call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & 'Minimum thickness for layer', & @@ -164,9 +164,9 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -179,9 +179,9 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -189,7 +189,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) + h(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo end select @@ -202,7 +202,7 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: just_read !< If true, this call will @@ -282,7 +282,7 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + GV%H_to_Z * h(i,j,k) / G%max_depth + xi1 = xi0 + h(i,j,k) / G%max_depth select case ( trim(density_profile) ) case ('linear') !S(i,j,k) = S_surf + S_range * 0.5 * (xi0 + xi1) diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 357f247896..75e5889092 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -57,7 +57,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure to parse for model parameter values. @@ -160,7 +160,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ! 4. Define layers do k = 1,nz - h(i,j,k) = GV%Z_to_H * (z_inter(k) - z_inter(k+1)) + h(i,j,k) = z_inter(k) - z_inter(k+1) enddo enddo ; enddo @@ -179,7 +179,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse !! for model parameter values. diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index b3b45da997..06a781ec94 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -32,7 +32,7 @@ subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] @@ -55,7 +55,7 @@ subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) y = G%geoLatT(i,j)-y0 val3 = exp(-val1*x) val4 = val2 * ( 2.0*val3 / (1.0 + (val3*val3)) )**2 - h(i,j,k) = GV%Z_to_H * (0.25*val4*(6.0*y*y + 3.0) * exp(-0.5*y*y) + depth_tot(i,j)) + h(i,j,k) = (0.25*val4*(6.0*y*y + 3.0) * exp(-0.5*y*y) + depth_tot(i,j)) enddo enddo ; enddo @@ -63,12 +63,11 @@ end subroutine soliton_initialize_thickness !> Initialization of u and v in the equatorial Rossby soliton test -subroutine soliton_initialize_velocity(u, v, h, G, GV, US) +subroutine soliton_initialize_velocity(u, v, G, GV, US) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index b9d16e548a..207f009c9c 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -76,12 +76,12 @@ subroutine USER_initialize_topography(D, G, param_file, max_depth, US) end subroutine USER_initialize_topography -!> initialize thicknesses. +!> Initialize thicknesses in depth units. These will be converted to thickness units later. subroutine USER_initialize_thickness(h, G, GV, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thicknesses being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thicknesses being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open !! file to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will @@ -93,7 +93,8 @@ subroutine USER_initialize_thickness(h, G, GV, param_file, just_read) if (just_read) return ! All run-time parameters have been read, so return. - h(:,:,1) = 0.0 ! h should be set [H ~> m or kg m-2]. + h(:,:,1:GV%ke) = 0.0 ! h should be set in [Z ~> m]. It will be converted to thickness units + ! [H ~> m or kg m-2] once the temperatures and salinities are known. if (first_call) call write_user_log(param_file) From 3be5d3a9ff4732945f997366cee7d63f6d5f1bc7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Apr 2023 13:50:12 -0400 Subject: [PATCH 75/91] +Add the new overloaded interface dz_to_thickness Renamed convert_thickness from MOM_state_initialization to dz_to_thickness_tv in MOM_density_integrals, so that it can be called from other lower-level modules. This new version also takes the tv%p_surf field into account and it has an optional halo_size argument, analogous to that in the other routines in the MOM_density_integrals module. The dz_to_thickness interface is overloaded so that it can also be used directly with temperature, salinity, and the equation of state type if the thermo_var_ptrs is not available. There is also a new and separate variant of this routine, dz_to_thickness_simple, that can be used in pure layered mode when temperature and salinity are not state variables, or (more dangerously) if it is not clear whether or not there is an equation of state. This simpler version is being kept separate from the main overloaded interface because its use may need to be revisited later in some cases. All answers are bitwise identical, but there are two new public interfaces, dz_to_thickness and dz_to_thickness_simple. --- src/core/MOM_interface_heights.F90 | 186 +++++++++++++++++- .../MOM_state_initialization.F90 | 89 +-------- 2 files changed, 190 insertions(+), 85 deletions(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index af444de941..4f41cb074b 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -3,25 +3,31 @@ module MOM_interface_heights ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_density_integrals, only : int_specific_vol_dp use MOM_error_handler, only : MOM_error, FATAL +use MOM_EOS, only : calculate_density, EOS_type, EOS_domain use MOM_file_parser, only : log_version use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_density_integrals, only : int_specific_vol_dp implicit none ; private #include -public find_eta +public find_eta, dz_to_thickness, dz_to_thickness_simple !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta module procedure find_eta_2d, find_eta_3d end interface find_eta +!> Calculates layer thickness in thickness units from geometric thicknesses in height units. +interface dz_to_thickness + module procedure dz_to_thickness_tv, dz_to_thickness_EoS +end interface dz_to_thickness + contains !> Calculates the heights of all interfaces between layers, using the appropriate @@ -246,4 +252,180 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) end subroutine find_eta_2d + +!> Converts thickness from geometric height units to thickness units, perhaps via an +!! inversion of the integral of the density in pressure using variables stored in +!! the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine dz_to_thickness_tv(dz, tv, h, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + else + if (associated(tv%eqn_of_state)) then + if (associated(tv%p_surf)) then + call dz_to_thickness_EOS(dz, tv%T, tv%S, tv%eqn_of_state, h, G, GV, US, halo, tv%p_surf) + else + call dz_to_thickness_EOS(dz, tv%T, tv%S, tv%eqn_of_state, h, G, GV, US, halo) + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (GV%Z_to_H*dz(i,j,k)) * (GV%Rlay(k) / GV%Rho0) + ! Consider revising this to the mathematically equivalent expression: + ! h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) + enddo ; enddo ; enddo + endif + endif + +end subroutine dz_to_thickness_tv + +!> Converts thickness from geometric height units to thickness units, working via an +!! inversion of the integral of the density in pressure when in non-Boussinesq mode. +subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_surf) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Temp !< Input layer temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Saln !< Input layer salinities [S ~> ppt] + type(EOS_type), intent(in) :: EoS !< Equation of state structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf !< Surface pressures [R L2 T-2 ~> Pa] + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + p_top, p_bot ! Pressure at the interfaces above and below a layer [R L2 T-2 ~> Pa] + real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] + real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] + real :: I_gEarth ! Unit conversion factors divided by the gravitational + ! acceleration [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, halo, nz + integer :: itt, max_itt + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + max_itt = 10 + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + else + I_gEarth = GV%RZ_to_H / GV%g_Earth + + if (present(p_surf)) then + do j=js,je ; do i=is,ie + p_bot(i,j) = 0.0 ; p_top(i,j) = p_surf(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 + enddo ; enddo + endif + EOSdom(:) = EOS_domain(G%HI) + + ! The iterative approach here is inherited from very old code that was in the + ! MOM_state_initialization module. It does converge, but it is very inefficient and + ! should be revised, although doing so would change answers in non-Boussinesq mode. + do k=1,nz + do j=js,je + do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo + call calculate_density(Temp(:,j,k), Saln(:,j,k), p_top(:,j), rho, & + EoS, EOSdom) + do i=is,ie + ! This could be simplified, but it would change answers at roundoff. + p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) + enddo + enddo + + do itt=1,max_itt + call int_specific_vol_dp(Temp(:,:,k), Saln(:,:,k), p_top, p_bot, 0.0, G%HI, & + EoS, US, dz_geo) + if (itt < max_itt) then ; do j=js,je + call calculate_density(Temp(:,j,k), Saln(:,j,k), p_bot(:,j), rho, & + EoS, EOSdom) + ! Use Newton's method to correct the bottom value. + ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. + do i=is,ie + p_bot(i,j) = p_bot(i,j) + rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) + enddo + enddo ; endif + enddo + + do j=js,je ; do i=is,ie + !### This code should be revised to use a dp variable for accuracy. + h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth + enddo ; enddo + enddo + endif + +end subroutine dz_to_thickness_EOS + +!> Converts thickness from geometric height units to thickness units, perhaps using +!! a simple conversion factor that may be problematic in non-Boussinesq mode. +subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + logical, optional, intent(in) :: layer_mode !< If present and true, do the conversion that + !! is appropriate in pure isopycnal layer mode with + !! no state variables or equation of state. Otherwise + !! use a simple constant rescaling factor and avoid the + !! use of GV%Rlay. + ! Local variables + logical :: layered ! If true and the model is non-Boussinesq, do calculations appropriate for use + ! in pure isopycnal layered mode with no state variables or equation of state. + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + layered = .false. ; if (present(layer_mode)) layered = layer_mode + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if (GV%Boussinesq .or. (.not.layered)) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + elseif (layered) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) + enddo ; enddo ; enddo + endif + +end subroutine dz_to_thickness_simple + end module MOM_interface_heights diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 45285c2e05..09755ec354 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -17,7 +17,7 @@ module MOM_state_initialization use MOM_file_parser, only : log_version use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, dz_to_thickness use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE @@ -418,7 +418,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call fill_temp_salt_segments(G, GV, US, OBC, tv) ! Convert thicknesses from geometric distances in depth units to thickness units or mass-per-unit-area. - if (new_sim .and. convert) call convert_thickness(dz, h, G, GV, US, tv) + if (new_sim .and. convert) call dz_to_thickness(dz, tv, h, G, GV, US) ! Handle the initial surface displacement under ice shelf call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & @@ -998,84 +998,6 @@ subroutine initialize_thickness_search call MOM_error(FATAL," MOM_state_initialization.F90, initialize_thickness_search: NOT IMPLEMENTED") end subroutine initialize_thickness_search -!> Converts thickness from geometric height units to thickness units -subroutine convert_thickness(dz, h, G, GV, US, tv) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: dz !< Input geometric layer thicknesses [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. - !! This is essentially intent out, but declared as intent - !! inout to preserve any initalized values in halo points. - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables - ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: & - p_top, p_bot ! Pressure at the interfaces above and below a layer [R L2 T-2 ~> Pa] - real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] - real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] - real :: I_gEarth ! Unit conversion factors divided by the gravitational acceleration - ! [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: itt, max_itt - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - max_itt = 10 - - if (GV%Boussinesq) then - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = GV%Z_to_H * dz(i,j,k) - enddo ; enddo ; enddo - else - I_gEarth = GV%RZ_to_H / GV%g_Earth - - if (associated(tv%eqn_of_state)) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 - enddo ; enddo - EOSdom(:) = EOS_domain(G%HI) - do k=1,nz - do j=js,je - do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & - tv%eqn_of_state, EOSdom) - do i=is,ie - ! This could be simplified, but it would change answers at roundoff. - p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) - enddo - enddo - - do itt=1,max_itt - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & - tv%eqn_of_state, US, dz_geo) - if (itt < max_itt) then ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & - tv%eqn_of_state, EOSdom) - ! Use Newton's method to correct the bottom value. - ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. - do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) - enddo - enddo ; endif - enddo - - do j=js,je ; do i=is,ie - h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth - enddo ; enddo - enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = (GV%Z_to_H*dz(i,j,k)) * (GV%Rlay(k) / GV%Rho0) - enddo ; enddo ; enddo - endif - endif - -end subroutine convert_thickness - !> Depress the sea-surface based on an initial condition file subroutine depress_surface(h, G, GV, US, param_file, tv, just_read, z_top_shelf) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -2844,8 +2766,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just GV_loc%ke = nkd allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used - ! Convert thicknesses to units of H. - call convert_thickness(dz1, h1, G, GV_loc, US, tv_loc) + ! Convert thicknesses to units of H, in non-Boussinesq mode by inverting integrals of + ! specific volume in pressure + call dz_to_thickness(dz1, tv_loc, h1, G, GV_loc, US) call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) @@ -2941,7 +2864,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just endif ! Now convert thicknesses to units of H. - call convert_thickness(dz, h, G, GV, US, tv) + call dz_to_thickness(dz, tv, h, G, GV, US) endif ! useALEremapping From fb5f4d7a6435e2fcc912f658eceb74ed195ed04a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 8 Apr 2023 07:28:46 -0400 Subject: [PATCH 76/91] (*)Improve non-Boussinesq initialization This commit includes three distinct sets of changes inside of MOM_state_initialization.F90 to better handle the initialization of non-Boussinesq models, none of which change any answers in Boussinesq models. These include: - Refactored trim_for_ice to have a separate, simpler form appropriate for use in non-Boussinesq mode. The units of the min_thickness argument to cut_off_column top were also changed to thickness units. - Initialize_sponges_file was refactored to work in depth-space variables before using dz_to_thickness to convert to thicknesses, but also to properly handle the case where the input file has a different number of vertical layers than the model is using, in which case the previous version could have had a segmentation fault. - Code in MOM_temp_salt_initialize_from_Z was reordered to more clearly group it into distinct phases. It also uses the new dz_to_thickness routine to convert input depths into thicknesses. All answers are bitwise identical in all Boussinesq test cases and all test cases in the MOM6-examples regression suite, but answers could be changed and improved in some non-Boussinesq cases. --- .../MOM_state_initialization.F90 | 213 +++++++++++------- 1 file changed, 126 insertions(+), 87 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 09755ec354..0321d7511a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -17,7 +17,7 @@ module MOM_state_initialization use MOM_file_parser, only : log_version use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell -use MOM_interface_heights, only : find_eta, dz_to_thickness +use MOM_interface_heights, only : find_eta, dz_to_thickness, dz_to_thickness_simple use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE @@ -1113,7 +1113,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) ! of temperature within each layer [C ~> degC] character(len=200) :: inputdir, filename, p_surf_file, p_surf_var ! Strings for file/path real :: scale_factor ! A file-dependent scaling factor for the input pressure [various]. - real :: min_thickness ! The minimum layer thickness, recast into Z units [Z ~> m]. + real :: min_thickness ! The minimum layer thickness [H ~> m or kg m-2]. real :: z_tolerance ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. integer :: i, j, k integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. @@ -1143,7 +1143,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) "file SURFACE_PRESSURE_FILE into a surface pressure.", & units="file dependent", default=1., do_not_log=just_read) call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & - units='m', default=1.e-3, scale=US%m_to_Z, do_not_log=just_read) + units='m', default=1.e-3, scale=GV%m_to_H, do_not_log=just_read) call get_param(PF, mdl, "TRIM_IC_Z_TOLERANCE", z_tolerance, & "The tolerance with which to find the depth matching the specified "//& "surface pressure with TRIM_IC_FOR_P_SURF.", & @@ -1300,7 +1300,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: G_earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: depth !< Depth of ocean column [Z ~> m]. - real, intent(in) :: min_thickness !< Smallest thickness allowed [Z ~> m]. + real, intent(in) :: min_thickness !< Smallest thickness allowed [H ~> m or kg m-2]. real, dimension(nk), intent(inout) :: T !< Layer mean temperature [C ~> degC] real, dimension(nk), intent(in) :: T_t !< Temperature at top of layer [C ~> degC] real, dimension(nk), intent(in) :: T_b !< Temperature at bottom of layer [C ~> degC] @@ -1323,51 +1323,75 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, real, dimension(nk) :: h0, h1 ! Initial and remapped layer thicknesses [H ~> m or kg m-2] real, dimension(nk) :: S0, S1 ! Initial and remapped layer salinities [S ~> ppt] real, dimension(nk) :: T0, T1 ! Initial and remapped layer temperatures [C ~> degC] - real :: P_t, P_b ! Top and bottom pressures [R L2 T-2 ~> Pa] + real :: P_t, P_b ! Top and bottom pressures [R L2 T-2 ~> Pa] real :: z_out, e_top ! Interface height positions [Z ~> m] + real :: min_dz ! The minimum thickness in depth units [Z ~> m] + real :: dh_surf_rem ! The remaining thickness to remove in non-Bousinesq mode [H ~> kg m-2] logical :: answers_2018 integer :: k answers_2018 = .true. ; if (present(remap_answer_date)) answers_2018 = (remap_answer_date < 20190101) - ! Calculate original interface positions - e(nk+1) = -depth - do k=nk,1,-1 - e(K) = e(K+1) + GV%H_to_Z*h(k) - h0(k) = h(nk+1-k) ! Keep a copy to use in remapping - enddo + ! Keep a copy of the initial thicknesses in reverse order to use in remapping + do k=1,nk ; h0(k) = h(nk+1-k) ; enddo - P_t = 0. - e_top = e(1) - do k=1,nk - call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & - US, P_b, z_out, z_tol=z_tol) - if (z_out>=e(K)) then - ! Imposed pressure was less that pressure at top of cell - exit - elseif (z_out<=e(K+1)) then - ! Imposed pressure was greater than pressure at bottom of cell - e_top = e(K+1) - else - ! Imposed pressure was fell between pressures at top and bottom of cell - e_top = z_out - exit - endif - P_t = P_b - enddo - if (e_top e_top) then - ! Original e(K) is too high - e(K) = e_top - e_top = e_top - min_thickness ! Next interface must be at least this deep + if (GV%Boussinesq) then + min_dz = GV%H_to_Z * min_thickness + ! Calculate original interface positions + e(nk+1) = -depth + do k=nk,1,-1 + e(K) = e(K+1) + GV%H_to_Z*h(k) + enddo + + P_t = 0. + e_top = e(1) + do k=1,nk + call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & + P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & + US, P_b, z_out, z_tol=z_tol) + if (z_out>=e(K)) then + ! Imposed pressure was less that pressure at top of cell + exit + elseif (z_out<=e(K+1)) then + ! Imposed pressure was greater than pressure at bottom of cell + e_top = e(K+1) + else + ! Imposed pressure was fell between pressures at top and bottom of cell + e_top = z_out + exit endif - ! This layer needs trimming - h(k) = GV%Z_to_H * max( min_thickness, e(K) - e(K+1) ) - if (e(K) < e_top) exit ! No need to go further + P_t = P_b enddo + if (e_top e_top) then + ! Original e(K) is too high + e(K) = e_top + e_top = e_top - min_dz ! Next interface must be at least this deep + endif + ! This layer needs trimming + h(k) = max( min_thickness, GV%Z_to_H * (e(K) - e(K+1)) ) + if (e(K) < e_top) exit ! No need to go further + enddo + endif + else + ! In non-Bousinesq mode, we are already in mass units so the calculation is much easier. + if (p_surf > 0.0) then + dh_surf_rem = p_surf * GV%RZ_to_H / G_earth + do k=1,nk + if (h(k) <= min_thickness) then ! This layer has no mass to remove. + cycle + elseif ((h(k) - min_thickness) < dh_surf_rem) then ! This layer should be removed entirely. + dh_surf_rem = dh_surf_rem - (h(k) - min_thickness) + h(k) = min_thickness + else ! This is the last layer that should be removed. + h(k) = h(k) - dh_surf_rem + dh_surf_rem = 0.0 + exit + endif + enddo + endif endif ! Now we need to remap but remapping assumes the surface is at the @@ -1855,6 +1879,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t !! overrides any value set for Time. ! Local variables real, allocatable, dimension(:,:,:) :: eta ! The target interface heights [Z ~> m]. + real, allocatable, dimension(:,:,:) :: dz ! The target interface thicknesses in height units [Z ~> m] real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses [H ~> m or kg m-2]. real, dimension (SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -1862,9 +1887,10 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t tmp2 ! A temporary array for salinities [S ~> ppt] real, dimension (SZI_(G),SZJ_(G)) :: & tmp_2d ! A temporary array for mixed layer densities [R ~> kg m-3] - real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading sponge target fields - ! on the vertical grid of the input file, used for both - ! temperatures [C ~> degC] and salinities [S ~> ppt] + real, allocatable, dimension(:,:,:) :: tmp_T ! A temporary array for reading sponge target temperatures + ! on the vertical grid of the input file [C ~> degC] + real, allocatable, dimension(:,:,:) :: tmp_S ! A temporary array for reading sponge target salinities + ! on the vertical grid of the input file [S ~> ppt] real, allocatable, dimension(:,:,:) :: tmp_u ! Temporary array for reading sponge target zonal ! velocities on the vertical grid of the input file [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:) :: tmp_v ! Temporary array for reading sponge target meridional @@ -1885,6 +1911,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t character(len=40) :: mdl = "initialize_sponges_file" character(len=200) :: damping_file, uv_damping_file, state_file, state_uv_file ! Strings for filenames character(len=200) :: filename, inputdir ! Strings for file/path and path. + type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure logical :: use_ALE ! True if ALE is being used, False if in layered mode logical :: time_space_interp_sponge ! If true use sponge data that need to be interpolated in both @@ -2057,35 +2084,51 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t call MOM_error(FATAL,"initialize_sponge_file: Array size mismatch for sponge data.") nz_data = siz(3)-1 allocate(eta(isd:ied,jsd:jed,nz_data+1)) - allocate(h(isd:ied,jsd:jed,nz_data)) + allocate(dz(isd:ied,jsd:jed,nz_data)) call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) do j=js,je ; do i=is,ie - eta(i,j,nz+1) = -depth_tot(i,j) + eta(i,j,nz_data+1) = -depth_tot(i,j) enddo ; enddo - do k=nz,1,-1 ; do j=js,je ; do i=is,ie + do k=nz_data,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) & eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z enddo ; enddo ; enddo - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = GV%Z_to_H*(eta(i,j,k)-eta(i,j,k+1)) + do k=1,nz_data ; do j=js,je ; do i=is,ie + dz(i,j,k) = eta(i,j,k)-eta(i,j,k+1) enddo; enddo ; enddo + deallocate(eta) + + allocate(h(isd:ied,jsd:jed,nz_data)) + if (use_temperature) then + allocate(tmp_T(isd:ied,jsd:jed,nz_data)) + allocate(tmp_S(isd:ied,jsd:jed,nz_data)) + call MOM_read_data(filename, potemp_var, tmp_T(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salin_var, tmp_S(:,:,:), G%Domain, scale=US%ppt_to_S) + endif + + GV_loc = GV ; GV_loc%ke = nz_data + if (use_temperature .and. associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, tmp_T, tmp_S, tv%eqn_of_state, h, G, GV_loc, US) + else + call dz_to_thickness_simple(dz, h, G, GV_loc, US, layer_mode=.true.) + endif + if (sponge_uv) then call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data, Idamp_u, Idamp_v) else call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data) endif - deallocate(eta) - deallocate(h) if (use_temperature) then - allocate(tmp_tr(isd:ied,jsd:jed,nz_data)) - call MOM_read_data(filename, potemp_var, tmp_tr(:,:,:), G%Domain, scale=US%degC_to_C) - call set_up_ALE_sponge_field(tmp_tr, G, GV, tv%T, ALE_CSp, 'temp', & + call set_up_ALE_sponge_field(tmp_T, G, GV, tv%T, ALE_CSp, 'temp', & sp_long_name='temperature', sp_unit='degC s-1') - call MOM_read_data(filename, salin_var, tmp_tr(:,:,:), G%Domain, scale=US%ppt_to_S) - call set_up_ALE_sponge_field(tmp_tr, G, GV, tv%S, ALE_CSp, 'salt', & + call set_up_ALE_sponge_field(tmp_S, G, GV, tv%S, ALE_CSp, 'salt', & sp_long_name='salinity', sp_unit='g kg-1 s-1') - deallocate(tmp_tr) + deallocate(tmp_S) + deallocate(tmp_T) endif + deallocate(h) + deallocate(dz) + if (sponge_uv) then filename = trim(inputdir)//trim(state_uv_file) call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_UV_FILE", filename) @@ -2723,11 +2766,32 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just enddo ; enddo deallocate( tmp_mask_in ) + ! Convert input thicknesses to units of H. In non-Boussinesq mode this is done by inverting + ! integrals of specific volume in pressure, so it can be expensive. + tv_loc = tv + tv_loc%T => tmpT1dIn + tv_loc%S => tmpS1dIn + GV_loc = GV + GV_loc%ke = nkd + call dz_to_thickness(dz1, tv_loc, h1, G, GV_loc, US) + ! Build the target grid (and set the model thickness to it) - ! This call can be more general but is hard-coded for z* coordinates... ???? + call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS + call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) - if (.not. remap_general) then + ! Now remap from source grid to target grid, first setting reconstruction parameters + if (remap_general) then + call set_regrid_params( regridCS, min_thickness=0. ) + allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used + + call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) + if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) + call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, & + frac_shelf_h=frac_shelf_h ) + + deallocate( dz_interface ) + else ! This is the old way of initializing to z* coordinates only allocate( hTarget(nz) ) hTarget = getCoordinateResolution( regridCS ) @@ -2747,36 +2811,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just enddo ; enddo deallocate( hTarget ) - do k=1,nkd ; do j=js,je ; do i=is,ie - h1(i,j,k) = GV%Z_to_H*dz1(i,j,k) - enddo ; enddo ; enddo - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = GV%Z_to_H*dz(i,j,k) - enddo ; enddo ; enddo + ! This is a simple conversion of the target grid to thickness units that may not be + ! appropriate in non-Boussinesq mode. + call dz_to_thickness_simple(dz, h, G, GV, US) endif - ! Now remap from source grid to target grid, first setting reconstruction parameters - call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) - if (remap_general) then - call set_regrid_params( regridCS, min_thickness=0. ) - tv_loc = tv - tv_loc%T => tmpT1dIn - tv_loc%S => tmpS1dIn - GV_loc = GV - GV_loc%ke = nkd - allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used - - ! Convert thicknesses to units of H, in non-Boussinesq mode by inverting integrals of - ! specific volume in pressure - call dz_to_thickness(dz1, tv_loc, h1, G, GV_loc, US) - - call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) - if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, & - frac_shelf_h=frac_shelf_h ) - - deallocate( dz_interface ) - endif call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & old_remap=remap_old_alg, answer_date=remap_answer_date ) call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & @@ -3073,7 +3112,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) write(0,*) ' ==================================================================== ' write(0,*) '' write(0,*) GV%H_to_m*h(:) - call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_Z, & + call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_H, & T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS, z_tol=z_tol) write(0,*) GV%H_to_m*h(:) From debe45e732825c8fdd181081ddc320f24627b0ce Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 8 Apr 2023 07:29:36 -0400 Subject: [PATCH 77/91] (*)Use dz_to_thickness in 4 user modules Use dz_to_thickness to convert vertical distances to layer thicknesses in the sponge initialization routines in the DOME2d_initialization, ISOMIP_initialization, dumbbell_initialization and dense_water_initialization modules, and also in MOM_initialize_tracer_from_Z. For the user modules, the presence or absence of an equation of state is known and handled properly, but MOM_initialize_tracer_from_Z works with the generic tracer code and it it outside of the scope of MOM6 code to provide any information about the equation of state or the state variables that would be needed to initialize a non-Boussinesq model properly from a depth-space input file. For now we are doing the best we can, but this should be revisited. All examples in existing test cases are bitwise identical, but answers could change (and be improved) in any non-Boussinesq variants of the relevant test cases. --- .../MOM_tracer_initialization_from_Z.F90 | 14 ++++- src/user/DOME2d_initialization.F90 | 24 ++++--- src/user/ISOMIP_initialization.F90 | 63 ++++++++++--------- src/user/dense_water_initialization.F90 | 24 ++++--- src/user/dumbbell_initialization.F90 | 32 +++++++--- 5 files changed, 105 insertions(+), 52 deletions(-) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index bd77ec54d5..64f6673371 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -12,6 +12,7 @@ module MOM_tracer_initialization_from_Z use MOM_file_parser, only : get_param, param_file_type, log_version use MOM_grid, only : ocean_grid_type use MOM_horizontal_regridding, only : myStats, horiz_interp_and_extrap_tracer +use MOM_interface_heights, only : dz_to_thickness_simple use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -75,10 +76,12 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ real, allocatable, dimension(:), target :: z_in ! Cell center depths for input data [Z ~> m] ! Local variables for ALE remapping - real, dimension(:,:,:), allocatable :: hSrc ! Source thicknesses [H ~> m or kg m-2]. + real, dimension(:,:,:), allocatable :: dzSrc ! Source thicknesses in height units [Z ~> m] + real, dimension(:,:,:), allocatable :: hSrc ! Source thicknesses [H ~> m or kg m-2] real, dimension(:), allocatable :: h1 ! A 1-d column of source thicknesses [Z ~> m]. real :: zTopOfCell, zBottomOfCell, z_bathy ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays + type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] integer :: nPoints ! The number of valid input data points in a column @@ -180,6 +183,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call cpu_clock_begin(id_clock_ALE) ! First we reserve a work space for reconstructions of the source data allocate( h1(kd) ) + allocate( dzSrc(isd:ied,jsd:jed,kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) ! Set parameters for reconstructions call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) @@ -204,12 +208,18 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ else tr(i,j,:) = 0. endif ! mask2dT - hSrc(i,j,:) = GV%Z_to_H * h1(:) + dzSrc(i,j,:) = h1(:) enddo ; enddo + ! Equation of state data is not available, so a simpler rescaling will have to suffice, + ! but it might be problematic in non-Boussinesq mode. + GV_loc = GV ; GV_loc%ke = kd + call dz_to_thickness_simple(dzSrc, hSrc, G, GV_loc, US) + call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date ) deallocate( hSrc ) + deallocate( dzSrc ) deallocate( h1 ) do k=1,nz diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 5cc63e734f..dade17a9a0 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -9,6 +9,7 @@ module DOME2d_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : dz_to_thickness, dz_to_thickness_simple use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -373,7 +374,8 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A ! Local variables real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [C ~> degC] real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [S ~> ppt] - real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness [H ~> m or kg m-2]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness in height units [Z ~> m] + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness [H ~> m or kg m-2] real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] @@ -478,30 +480,38 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo - ! Store the grid on which the T/S sponge data will reside - call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) ! Construct temperature and salinity on the arbitrary grid T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 do j=js,je ; do i=is,ie z = -depth_tot(i,j) do k = nz,1,-1 - z = z + 0.5 * GV%H_to_Z * h(i,j,k) ! Position of the center of layer k + z = z + 0.5 * dz(i,j,k) ! Position of the center of layer k ! Use salinity stratification in the eastern sponge. S(i,j,k) = S_surf - S_range_sponge * (z / G%max_depth) ! Use a constant salinity in the western sponge. if ( ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon < dome2d_west_sponge_width ) & S(i,j,k) = S_ref + S_range - z = z + 0.5 * GV%H_to_Z * h(i,j,k) ! Position of the interface k + z = z + 0.5 * dz(i,j,k) ! Position of the interface k enddo enddo ; enddo + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call dz_to_thickness_simple(dz, h, G, GV, US, layer_mode=.true.) + endif + + ! Store damping rates and the grid on which the T/S sponge data will reside + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & sp_long_name='temperature', sp_unit='degC s-1') if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 7e3299b372..232ce6d4e7 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -10,6 +10,7 @@ module ISOMIP_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : dz_to_thickness use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -146,8 +147,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file - !! to parse for model parameter values. + type(param_file_type), intent(in) :: param_file !< A structure to parse for model parameter values type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields, including !! the eqn. of state. @@ -440,27 +440,25 @@ end subroutine ISOMIP_initialize_temperature_salinity ! the values towards which the interface heights and an arbitrary ! number of tracers should be restored within each sponge. subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ACSp) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers - !! to any available thermodynamic - !! fields, potential temperature and - !! salinity or mixed layer density. - !! Absent fields have NULL ptrs. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: PF !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode - type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure - type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: PF !< A structure to parse for model parameter values + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure ! Local variables real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [C ~> degC] real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [S ~> ppt] ! real :: RHO(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for RHO [R ~> kg m-3] - real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness [H ~> m or kg m-2] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses in height units [Z ~> m] + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses [H ~> m or kg m-2] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] real :: S_sur, S_bot ! Surface and bottom salinities in the sponge region [S ~> ppt] @@ -582,9 +580,9 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -596,16 +594,16 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness * GV%Z_to_H + dz(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / real(nz)) + dz(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo case default @@ -614,21 +612,25 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, end select - ! This call sets up the damping rates and interface heights. - ! This sets the inverse damping timescale fields in the sponges. - call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) - dS_dz = (S_sur - S_bot) / G%max_depth dT_dz = (T_sur - T_bot) / G%max_depth do j=js,je ; do i=is,ie xi0 = -depth_tot(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth in middle of layer + xi0 = xi0 + 0.5 * dz(i,j,k) ! Depth in middle of layer S(i,j,k) = S_sur + dS_dz * xi0 T(i,j,k) = T_sur + dT_dz * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth at top of layer + xi0 = xi0 + 0.5 * dz(i,j,k) ! Depth at top of layer enddo enddo ; enddo + + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call MOM_error(FATAL, "The ISOMIP test case requires an equation of state.") + endif + ! for debugging !i=G%iec; j=G%jec !do k = 1,nz @@ -637,6 +639,9 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ! call MOM_mesg(mesg,5) !enddo + ! This call sets up the damping rates and interface heights in the sponges. + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) + ! Now register all of the fields which are damped in the sponge. ! ! By default, momentum is advected vertically within the sponge, but ! ! momentum is typically not damped within the sponge. ! diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 6feb2bdda6..03cc983a9f 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -9,6 +9,7 @@ module dense_water_initialization use MOM_EOS, only : EOS_type use MOM_error_handler, only : MOM_error, FATAL use MOM_file_parser, only : get_param, param_file_type +use MOM_interface_heights, only : dz_to_thickness, dz_to_thickness_simple use MOM_grid, only : ocean_grid_type use MOM_sponge, only : sponge_CS use MOM_unit_scaling, only : unit_scale_type @@ -172,7 +173,8 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, real :: east_sponge_width ! The fraction of the domain in which the eastern (outflow) sponge is active [nondim] real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h ! sponge thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! sponge layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h ! sponge layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T ! sponge temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S ! sponge salinity [S ~> ppt] real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge [Z ~> m] @@ -256,16 +258,14 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then ! is this layer vanished? eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo enddo - call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) - ! construct temperature and salinity for the sponge ! start with initial condition T(:,:,:) = T_ref @@ -277,7 +277,7 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, x = (G%geoLonT(i,j) - G%west_lon) / G%len_lon do k = 1,nz ! nondimensional middle of layer - zmid = zi + 0.5 * h(i,j,k) / (GV%Z_to_H * G%max_depth) + zmid = zi + 0.5 * dz(i,j,k) / G%max_depth if (x > (1. - east_sponge_width)) then !if (zmid >= 0.9 * sill_frac) & @@ -288,11 +288,21 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) endif - zi = zi + h(i,j,k) / (GV%Z_to_H * G%max_depth) + zi = zi + dz(i,j,k) / G%max_depth enddo enddo enddo + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call dz_to_thickness_simple(dz, h, G, GV, US, layer_mode=.true.) + endif + + ! This call sets up the damping rates and interface heights in the sponges. + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & sp_long_name='temperature', sp_unit='degC s-1') if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index abd4f4f37e..b2ed47f89b 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -9,6 +9,7 @@ module dumbbell_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : dz_to_thickness, dz_to_thickness_simple use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS use MOM_tracer_registry, only : tracer_registry_type use MOM_unit_scaling, only : unit_scale_type @@ -349,8 +350,11 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil real :: sponge_time_scale ! The damping time scale [T ~> s] real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h ! sponge thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S ! sponge salinities [S ~> ppt] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge thicknesses in height units [Z ~> m] + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge thicknesses [H ~> m or kg m-2] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge salinities [S ~> ppt] + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge tempertures [C ~> degC], used only to convert thicknesses + ! in non-Boussinesq mode real, dimension(SZK_(GV)+1) :: eta1D ! Interface positions for ALE sponge [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! A temporary array for interface heights [Z ~> m]. @@ -359,6 +363,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil real :: dblen ! The size of the dumbbell test case [km] or [m] real :: min_thickness ! The minimum layer thickness [Z ~> m] real :: S_ref, S_range ! A reference salinity and the range of salinities in this test case [S ~> ppt] + real :: T_surf ! The surface temperature [C ~> degC] logical :: dbrotate ! If true, rotate the domain. call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & @@ -377,6 +382,9 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil call get_param(param_file, mdl, "DUMBBELL_SPONGE_TIME_SCALE", sponge_time_scale, & "The time scale in the reservoir for restoring. If zero, the sponge is disabled.", & units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "DUMBBELL_T_SURF", T_surf, & + 'Initial surface temperature in the DUMBBELL configuration', & + units='degC', default=20., scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "DUMBBELL_SREF", S_ref, & 'DUMBBELL REFERENCE SALINITY', & units='1e-3', default=34., scale=US%ppt_to_S, do_not_log=.true.) @@ -419,18 +427,17 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + dz(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo - call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) - ! construct temperature and salinity for the sponge ! start with initial condition S(:,:,:) = 0.0 + T(:,:,:) = T_surf do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Compute normalized zonal coordinates (x,y=0 at center of domain) @@ -451,7 +458,18 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil enddo endif enddo ; enddo - if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + + ! Convert thicknesses from height units to thickness units + if (associated(tv%eqn_of_state)) then + call dz_to_thickness(dz, T, S, tv%eqn_of_state, h, G, GV, US) + else + call dz_to_thickness_simple(dz, h, G, GV, US, layer_mode=.true.) + endif + + ! Store damping rates and the grid on which the T/S sponge data will reside + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) + + if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & sp_long_name='salinity', sp_unit='g kg-1 s-1') else do j=G%jsc,G%jec ; do i=G%isc,G%iec From 89f91bddba56003a8d5957546636db8b642dfc01 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 12 May 2023 10:05:26 -0400 Subject: [PATCH 78/91] Update the Gitlab .testing modules for c5 In preparation for the migration to C5, this patch updates the modules required to run the .testing suite. --- .gitlab-ci.yml | 86 ++++++++++++++++++------------------- .gitlab/pipeline-ci-tool.sh | 12 +++--- 2 files changed, 50 insertions(+), 48 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 653734097b..6be281c8cd 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -21,7 +21,7 @@ before_script: p:merge: stage: setup tags: - - ncrc4 + - ncrc5 script: - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl @@ -31,7 +31,7 @@ p:merge: p:clone: stage: setup tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh create-job-dir #.gitlab/pipeline-ci-tool.sh clean-job-dir @@ -44,7 +44,7 @@ p:clone: s:work-space:pgi: stage: setup tags: - - ncrc4 + - ncrc5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space pgi @@ -52,7 +52,7 @@ s:work-space:pgi: s:work-space:intel: stage: setup tags: - - ncrc4 + - ncrc5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space intel @@ -60,7 +60,7 @@ s:work-space:intel: s:work-space:gnu: stage: setup tags: - - ncrc4 + - ncrc5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space gnu @@ -68,7 +68,7 @@ s:work-space:gnu: s:work-space:gnu-restarts: stage: setup tags: - - ncrc4 + - ncrc5 needs: ["p:clone"] script: - .gitlab/pipeline-ci-tool.sh copy-test-space gnu-rst @@ -82,7 +82,7 @@ compile:pgi:repro: stage: builds needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_pgi @@ -90,7 +90,7 @@ compile:intel:repro: stage: builds needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_intel @@ -98,7 +98,7 @@ compile:gnu:repro: stage: builds needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu @@ -106,7 +106,7 @@ compile:gnu:debug: stage: builds needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh mrs-compile debug_gnu @@ -114,7 +114,7 @@ compile:gnu:ocean-only-nolibs: stage: builds needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh nolibs-ocean-only-compile gnu @@ -122,7 +122,7 @@ compile:gnu:ice-ocean-nolibs: stage: builds needs: ["p:clone"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu @@ -132,36 +132,36 @@ run:pgi: stage: run needs: ["s:work-space:pgi","compile:pgi:repro"] tags: - - ncrc4 + - ncrc5 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=1:00:00 --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite pgi SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite pgi SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-pgi-SNL || ( echo Batch job did not complete ; exit 911 ) run:intel: stage: run needs: ["s:work-space:intel","compile:intel:repro"] tags: - - ncrc4 + - ncrc5 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=1:00:00 --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite intel SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite intel SNL && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-intel-SNL || ( echo Batch job did not complete ; exit 911 ) run:gnu: stage: run needs: ["s:work-space:gnu","compile:gnu:repro","compile:gnu:debug"] tags: - - ncrc4 + - ncrc5 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=1:00:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu SNLDT && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu SNLDT && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-SNLDT || ( echo Batch job did not complete ; exit 911 ) run:gnu-restarts: stage: run needs: ["s:work-space:gnu-restarts","compile:gnu:repro"] tags: - - ncrc4 + - ncrc5 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=1:00:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu R && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) + - sbatch --clusters=c5 --nodes=12 --time=15:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait .gitlab/pipeline-ci-tool.sh run-suite gnu R && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-R || ( echo Batch job did not complete ; exit 911 ) # GH/autoconf tests (duplicates the GH actions tests) @@ -173,7 +173,7 @@ actions:gnu: stage: tests needs: [] tags: - - ncrc4 + - ncrc5 before_script: - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" - git submodule init ; git submodule update @@ -181,19 +181,19 @@ actions:gnu: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan ; module load PrgEnv-gnu ; module unload netcdf gcc ; module load gcc/7.3.0 cray-hdf5 cray-netcdf + - module unload PrgEnv-gnu PrgEnv-intel PrgEnv-nvhpc ; module load PrgEnv-gnu ; module unload gcc ; module load gcc/12.2.0 cray-hdf5 cray-netcdf - make -s -j - MPIRUN= make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" WORKSPACE=$WORKSPACE test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make WORKSPACE=$WORKSPACE test -s + - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make WORKSPACE=$WORKSPACE test -s - make WORKSPACE=$WORKSPACE test.summary actions:intel: stage: tests needs: [] tags: - - ncrc4 + - ncrc5 before_script: - echo -e "\e[0Ksection_start:`date +%s`:submodules[collapsed=true]\r\e[0KCloning submodules" - git submodule init ; git submodule update @@ -201,12 +201,12 @@ actions:intel: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan; module load PrgEnv-intel; module unload netcdf intel; module load intel/18.0.6.288 cray-hdf5 cray-netcdf + - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu ; module load PrgEnv-intel; module unload intel; module load intel-classic/2022.0.2 cray-hdf5 cray-netcdf - make -s -j - MPIRUN= make preproc -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" WORKSPACE=$WORKSPACE test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.intel.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make WORKSPACE=$WORKSPACE test -s + - sbatch --clusters=c5 --nodes=2 --time=0:10:00 --account=gfdl_o --qos=debug --job-name=MOM6.intel.testing --output=log.$CI_JOB_ID --wait job.sh || ( cat log.$CI_JOB_ID ; exit 911 ) && make WORKSPACE=$WORKSPACE test -s - make WORKSPACE=$WORKSPACE test.summary # Tests @@ -218,7 +218,7 @@ t:pgi:symmetric: stage: tests needs: ["run:pgi"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi S @@ -226,7 +226,7 @@ t:pgi:non-symmetric: stage: tests needs: ["run:pgi"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi N @@ -234,7 +234,7 @@ t:pgi:layout: stage: tests needs: ["run:pgi"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats pgi L @@ -242,7 +242,7 @@ t:pgi:params: stage: tests needs: ["run:pgi"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-params pgi allow_failure: true @@ -251,7 +251,7 @@ t:intel:symmetric: stage: tests needs: ["run:intel"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel S @@ -259,7 +259,7 @@ t:intel:non-symmetric: stage: tests needs: ["run:intel"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel N @@ -267,7 +267,7 @@ t:intel:layout: stage: tests needs: ["run:intel"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats intel L @@ -275,7 +275,7 @@ t:intel:params: stage: tests needs: ["run:intel"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-params intel allow_failure: true @@ -284,7 +284,7 @@ t:gnu:symmetric: stage: tests needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu S @@ -292,7 +292,7 @@ t:gnu:non-symmetric: stage: tests needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu N @@ -300,7 +300,7 @@ t:gnu:layout: stage: tests needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu L @@ -308,7 +308,7 @@ t:gnu:static: stage: tests needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu T @@ -316,7 +316,7 @@ t:gnu:symmetric-debug: stage: tests needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu D @@ -324,7 +324,7 @@ t:gnu:restart: stage: tests needs: ["run:gnu-restarts"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-stats gnu R @@ -332,7 +332,7 @@ t:gnu:params: stage: tests needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-params gnu allow_failure: true @@ -341,7 +341,7 @@ t:gnu:diags: stage: tests needs: ["run:gnu"] tags: - - ncrc4 + - ncrc5 script: - .gitlab/pipeline-ci-tool.sh check-diags gnu allow_failure: true @@ -350,7 +350,7 @@ t:gnu:diags: cleanup: stage: cleanup tags: - - ncrc4 + - ncrc5 before_script: - echo Skipping usual preamble script: diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh index 641e9f6053..a671fe8b23 100755 --- a/.gitlab/pipeline-ci-tool.sh +++ b/.gitlab/pipeline-ci-tool.sh @@ -2,7 +2,7 @@ # Environment variables set by gitlab (the CI environment) if [ -z $JOB_DIR ]; then - echo Environment variable "$"JOB_DIR should be defined to point to a unique directory for these scripts to use. + echo Environment variable "$"JOB_DIR should be defined to point to a unique directory for these scripts to use. echo '$JOB_DIR is derived from $CI_PIPELINE_ID in MOM6/.gitlab-ci.yml' echo 'To use interactively try:' echo ' JOB_DIR=tmp' $0 $@ @@ -138,7 +138,7 @@ nolibs-ocean-only-compile () { make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. ENVIRON=../../environ -s ../src/mkmf/bin/list_paths -l ../src/MOM6/config_src/{drivers/solo_driver,memory/dynamic_symmetric,infra/FMS1,ext*} ../src/MOM6/src ../src/FMS1 sed -i '/FMS1\/.*\/test_/d' path_names - ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names + ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc5-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) fi section-end nolibs-ocean-only-compile-$1 @@ -156,7 +156,7 @@ nolibs-ocean-ice-compile () { make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. ENVIRON=../../environ -s ../src/mkmf/bin/list_paths -l ../src/MOM6/config_src/{drivers/FMS_cap,memory/dynamic_symmetric,infra/FMS1,ext*} ../src/MOM6/src ../src/SIS2/*src ../src/{FMS1,coupler,icebergs,ice_param,land_null,atmos_null} sed -i '/FMS1\/.*\/test_/d' path_names - ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names + ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc5-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) fi section-end nolibs-ocean-ice-compile-$1 @@ -208,8 +208,10 @@ mrs-run-sub-suite () { clean-params $EXP_GROUPS clean-core-files $EXP_GROUPS if [[ "$3" == *"_nonsym"* ]]; then + set -e time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.$1 MEMORY=${3/_nonsym/_sym} MODE=$4 LAYOUT=$5 -s -j fi + set -e time make -f tools/MRS/Makefile.run $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j tar cf - `find $EXP_GROUPS -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/$1-$2-$3-$4-$5-stats -xf - tar cf - `find $EXP_GROUPS -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/$1-$2-$3-$4-$5-params -xf - @@ -291,7 +293,7 @@ run-suite () { # $2 is path of correct results to test against (relative to $STATS_REPO_DIR) compare-stats () { if [ "$#" -ne 2 ]; then echo "compare-stats needs 2 arguments" ; exit 911 ; fi - section-start-open compare-stats-$1-$2-$3-$4-$5 "Checking stats for '$1' against '$2'" + section-start-open compare-stats-$1-$2-$3-$4-$5 "Checking stats for '$1' against '$2'" # This checks that any file in the results directory is exactly the same as in regressions/ ( cd $JOB_DIR/$STATS_REPO_DIR/$1 ; md5sum `find * -type f` ) | ( cd $JOB_DIR/$STATS_REPO_DIR/$2 ; md5sum -c ) 2>&1 | sed "s/ OK/$GRN&$OFF/;s/ FAILED/$RED&$OFF/;s/WARNING/$RED&$OFF/" FAIL=${PIPESTATUS[1]} @@ -409,7 +411,7 @@ while [[ $# -gt 0 ]]; do # Loop through arguments cd $START_DIR arg=$1 shift - case "$arg" in + case "$arg" in -n | --norun) DRYRUN=1; echo Dry-run enabled; continue ;; +n | ++norun) From 50d8bdad359786cfdabe80a2131756b705bd850e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sat, 10 Dec 2022 18:09:32 -0500 Subject: [PATCH 79/91] POSIX: generic wrappers for all setjmp.h symbols This patch extends the generic wrappers of sigsetjmp to all of the *jmp wrapper functions in The C standard allows these to be defined as macros, rather than explicit functions, which cannot be referenced by Fortran C bindings, so we cannot assume that these functions exist, even when using a compliant libc. As with sigsetjmp, these functions are now disabled on default, and raise a runtime error if called by the program. Realistically, they will only be defined by an autoconf-configured build. This is required for older Linux distributions where libc does not define longjmp. --- ac/configure.ac | 31 ++++++++++++++++++++----- src/framework/posix.F90 | 51 +++++++++++++++++++++++++++++++++++------ src/framework/posix.h | 16 +++++++++++-- 3 files changed, 83 insertions(+), 15 deletions(-) diff --git a/ac/configure.ac b/ac/configure.ac index dead0579a6..9a634c1255 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -242,12 +242,24 @@ AC_CONFIG_COMMANDS(Makefile.dep, [make depend]) # POSIX verification tests -# These symbols may be defined as macros, making them inaccessible by Fortran. -# These three exist in modern BSD and Linux libc, so we just confirm them. -# But one day, we many need to handle them more carefully. -AX_FC_CHECK_BIND_C([setjmp], [], [AC_MSG_ERROR([Could not find setjmp.])]) -AX_FC_CHECK_BIND_C([longjmp], [], [AC_MSG_ERROR([Could not find longjmp.])]) -AX_FC_CHECK_BIND_C([siglongjmp], [], [AC_MSG_ERROR([Could not find siglongjmp.])]) +# Symbols in may be defined as macros, making them inaccessible by +# Fortran C bindings. `sigsetjmp` is known to have an internal symbol in +# glibc, so we check for this possibility. For the others, we only check for +# existence. + +# If the need arises, we may want to define these under a standalone macro. + +# Validate the setjmp symbol +AX_FC_CHECK_BIND_C([setjmp], + [SETJMP="setjmp"], [SETJMP="setjmp_missing"] +) +AC_DEFINE_UNQUOTED([SETJMP_NAME], ["${SETJMP}"]) + +# Validate the longjmp symbol +AX_FC_CHECK_BIND_C([longjmp], + [LONGJMP="longjmp"], [LONGJMP="longjmp_missing"] +) +AC_DEFINE_UNQUOTED([LONGJMP_NAME], ["${LONGJMP}"]) # Determine the sigsetjmp symbol. If missing, then point to sigsetjmp_missing. # @@ -263,6 +275,13 @@ for sigsetjmp_fn in sigsetjmp __sigsetjmp; do done AC_DEFINE_UNQUOTED([SIGSETJMP_NAME], ["${SIGSETJMP}"]) +# Validate the siglongjmp symbol +AX_FC_CHECK_BIND_C([siglongjmp], + [SIGLONGJMP="siglongjmp"], [SETJMP="siglongjmp_missing"] +) +AC_DEFINE_UNQUOTED([SIGLONGJMP_NAME], ["${SIGLONGJMP}"]) + + # Verify the size of nonlocal jump buffer structs # NOTE: This requires C compiler, but can it be done with a Fortran compiler? AC_LANG_PUSH([C]) diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index e5ec0e60d4..213ff4656d 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -137,7 +137,7 @@ function sleep_posix(seconds) result(rc) bind(c, name="sleep") !! returns 0. When `longjmp` is later called, the program is restored to the !! point where `setjmp` was called, except it now returns a value (rc) as !! specified by `longjmp`. - function setjmp(env) result(rc) bind(c, name="setjmp") + function setjmp(env) result(rc) bind(c, name=SETJMP_NAME) ! #include ! int setjmp(jmp_buf env); import :: jmp_buf, c_int @@ -175,7 +175,7 @@ end function sigsetjmp !> C interface to POSIX longjmp() !! Users should use the Fortran-defined longjmp() function. - subroutine longjmp_posix(env, val) bind(c, name="longjmp") + subroutine longjmp_posix(env, val) bind(c, name=LONGJMP_NAME) ! #include ! int longjmp(jmp_buf env, int val); import :: jmp_buf, c_int @@ -188,7 +188,7 @@ end subroutine longjmp_posix !> C interface to POSIX siglongjmp() !! Users should use the Fortran-defined siglongjmp() function. - subroutine siglongjmp_posix(env, val) bind(c, name="siglongjmp") + subroutine siglongjmp_posix(env, val) bind(c, name=SIGLONGJMP_NAME) ! #include ! int siglongjmp(jmp_buf env, int val); import :: sigjmp_buf, c_int @@ -344,11 +344,36 @@ subroutine siglongjmp(env, val) call siglongjmp_posix(env, val_c) end subroutine siglongjmp + +! Symbols in may be platform-dependent and may not exist if defined +! as a macro. The following functions permit compilation when they are +! unavailable, and report a runtime error if used in the program. + +!> Placeholder function for a missing or unconfigured setjmp +function setjmp_missing(env) result(rc) bind(c) + type(jmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int) :: rc + !< Function return code (unused) + + print '(a)', 'ERROR: setjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSETJMP_NAME=\"\".' + error stop +end function setjmp_missing + +!> Placeholder function for a missing or unconfigured longjmp +subroutine longjmp_missing(env, val) bind(c) + type(jmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: val + !< Enable signal state flag (unused) + + print '(a)', 'ERROR: longjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DLONGJMP_NAME=\"\".' + error stop +end subroutine longjmp_missing + !> Placeholder function for a missing or unconfigured sigsetjmp -!! -!! The symbol for sigsetjmp can be platform-dependent and may not exist if -!! defined as a macro. This function allows compilation, and reports a runtime -!! error if used in the program. function sigsetjmp_missing(env, savesigs) result(rc) bind(c) type(sigjmp_buf), intent(in) :: env !< Current process state (unused) @@ -365,4 +390,16 @@ function sigsetjmp_missing(env, savesigs) result(rc) bind(c) rc = -1 end function sigsetjmp_missing +!> Placeholder function for a missing or unconfigured siglongjmp +subroutine siglongjmp_missing(env, val) bind(c) + type(sigjmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: val + !< Enable signal state flag (unused) + + print '(a)', 'ERROR: siglongjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSIGLONGJMP_NAME=\"\".' + error stop +end subroutine siglongjmp_missing + end module posix diff --git a/src/framework/posix.h b/src/framework/posix.h index 96dec57814..f7cea0fec9 100644 --- a/src/framework/posix.h +++ b/src/framework/posix.h @@ -12,12 +12,24 @@ #define SIZEOF_SIGJMP_BUF SIZEOF_JMP_BUF #endif -! glibc defines sigsetjmp as __sigsetjmp via macro readable from . +! Wrappers to are disabled on default. +#ifndef SETJMP_NAME +#define SETJMP_NAME "setjmp_missing" +#endif + +#ifndef LONGJMP_NAME +#define LONGJMP_NAME "longjmp_missing" +#endif + #ifndef SIGSETJMP_NAME #define SIGSETJMP_NAME "sigsetjmp_missing" #endif -! This should be defined by /usr/include/signal.h +#ifndef SIGLONGJMP_NAME +#define SIGLONGJMP_NAME "siglongjmp_missing" +#endif + +! This should be defined by ; ! If unset, we use the most common (x86) value #ifndef POSIX_SIGUSR1 #define POSIX_SIGUSR1 10 From 0fa10ad1f24509af212e3caba670dfcbceb1fd71 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 8 May 2023 14:57:46 -0400 Subject: [PATCH 80/91] Autoconf: External FMS build configuration This patch modifies the `ac/deps` Makefile used to build the FMS depedency. The autoconf compilation is now done entirely outside of the `ac/deps/fms/src` directory. This keeps the FMS checkout unchanged and allows us to better track any development changes in that library during development. The .testing/Makefile was also modified to use existing rules in deps/Makefile rather than duplicating them. Dependency of the m4 directory is also now more explicit (albeit still somewhat incomplete). --- .testing/Makefile | 33 ++++++++++++--------------------- ac/deps/Makefile | 25 ++++++++++++++----------- 2 files changed, 26 insertions(+), 32 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 8a79d86e0a..237daadd96 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -331,32 +331,23 @@ FMS_ENV = \ FCFLAGS="$(FCFLAGS_FMS)" \ REPORT_ERROR_LOGS="$(REPORT_ERROR_LOGS)" -deps/lib/libFMS.a: deps/fms/build/libFMS.a - $(MAKE) -C deps lib/libFMS.a +deps/lib/libFMS.a: deps/Makefile deps/Makefile.fms.in deps/configure.fms.ac deps/m4 + $(FMS_ENV) $(MAKE) -C deps lib/libFMS.a -deps/fms/build/libFMS.a: deps/fms/build/Makefile - $(MAKE) -C deps fms/build/libFMS.a +deps/Makefile: ../ac/deps/Makefile | deps + cp ../ac/deps/Makefile deps/Makefile -deps/fms/build/Makefile: deps/fms/src/configure deps/Makefile.fms.in - $(FMS_ENV) $(MAKE) -C deps fms/build/Makefile +deps/Makefile.fms.in: ../ac/deps/Makefile.fms.in | deps + cp ../ac/deps/Makefile.fms.in deps/Makefile.fms.in -deps/Makefile.fms.in: ../ac/deps/Makefile.fms.in deps/Makefile - cp $< deps +deps/configure.fms.ac: ../ac/deps/configure.fms.ac | deps + cp ../ac/deps/configure.fms.ac deps/configure.fms.ac -# TODO: m4 dependencies? -deps/fms/src/configure: ../ac/deps/configure.fms.ac deps/Makefile $(FMS_SOURCE) | deps/fms/src - cp ../ac/deps/configure.fms.ac deps - cp -r ../ac/deps/m4 deps - $(MAKE) -C deps fms/src/configure - -deps/fms/src: deps/Makefile - make -C deps fms/src - -# Dependency init -deps/Makefile: ../ac/deps/Makefile - mkdir -p $(@D) - cp $< $@ +deps/m4: ../ac/deps/m4 | deps + cp -r ../ac/deps/m4 deps/ +deps: + mkdir -p deps #--- # The following block does a non-library build of a coupled driver interface to diff --git a/ac/deps/Makefile b/ac/deps/Makefile index 84d43eb26d..3263dde678 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -41,33 +41,36 @@ lib/libFMS.a: fms/build/libFMS.a cp fms/build/libFMS.a lib/libFMS.a cp fms/build/*.mod include - fms/build/libFMS.a: fms/build/Makefile - make -C fms/build libFMS.a - + $(MAKE) -C fms/build libFMS.a -fms/build/Makefile: Makefile.fms.in fms/src/configure - mkdir -p fms/build - cp Makefile.fms.in fms/src/Makefile.in +fms/build/Makefile: fms/build/Makefile.in fms/build/configure cd $(@D) && { \ - ../src/configure --srcdir=../src \ + ./configure --srcdir=../src \ || { \ if [ "${REPORT_ERROR_LOGS}" = true ]; then cat config.log ; fi ; \ false; \ } \ } +fms/build/Makefile.in: Makefile.fms.in | fms/build + cp Makefile.fms.in fms/build/Makefile.in -fms/src/configure: configure.fms.ac $(FMS_SOURCE) | fms/src - cp configure.fms.ac fms/src/configure.ac - cp -r m4 $(@D) - cd $(@D) && autoreconf -i +fms/build/configure: fms/build/configure.ac $(FMS_SOURCE) | fms/src + autoreconf fms/build +fms/build/configure.ac: configure.fms.ac m4 | fms/build + cp configure.fms.ac fms/build/configure.ac + cp -r m4 fms/build + +fms/build: + mkdir -p fms/build fms/src: git clone $(FMS_URL) $@ git -C $@ checkout $(FMS_COMMIT) +# Cleanup .PHONY: clean clean: From 501fcff4a486febad18e5344b42b1637efd8be12 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 11 May 2023 09:37:56 -0400 Subject: [PATCH 81/91] Autoconf: Explicit MOM_memory.h configuration MOM6 requires an explicit MOM_memory.h header to define its numerical field memory layout. Previously, autoconf provided a flag to configure this with `--enable-*`, but was prone to two issues: * The binary choice of symmetric/nonsymmetric prevented use of static headers. * It was an incorrect use of `--enable-*`, which is intended to enable additional internal features; it is not used to select a mode. To address these issues, we drop the flag and replace it with an AC_ARG_VAR variable, MOM_MEMORY, which is a path to the file. This variable will default to dynamic symmetric mode, config_src/memory/dynamic_symmetric/MOM_memory.h so there should be no change for existing users. To the best of my knowledge, no one used the `--enable-*` flag, nor was it used in any automated systems (outside of .testing), so there should be no issue with dropping it. .testing/Makefile was updated to use MOM_MEMORY. --- .testing/Makefile | 5 +++-- ac/configure.ac | 40 ++++++++++++++++++++++++++++++---------- 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 237daadd96..a28bcc4bc4 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -246,7 +246,8 @@ COV_LDFLAGS := LDFLAGS="$(LDFLAGS_COVERAGE) $(LDFLAGS_DEPS) $(LDFLAGS_USER)" # Environment variable configuration build/symmetric/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/asymmetric/Makefile: MOM_ENV=$(PATH_FMS) $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/asymmetric/Makefile: MOM_ENV=$(PATH_FMS) $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) \ + MOM_MEMORY=../../../config_src/memory/dynamic_nonsymmetric/MOM_memory.h build/repro/Makefile: MOM_ENV=$(PATH_FMS) $(REPRO_FCFLAGS) $(MOM_LDFLAGS) build/openmp/Makefile: MOM_ENV=$(PATH_FMS) $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) build/target/Makefile: MOM_ENV=$(PATH_FMS) $(TARGET_FCFLAGS) $(MOM_LDFLAGS) @@ -260,7 +261,7 @@ build/unit/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) # Configure script flags build/symmetric/Makefile: MOM_ACFLAGS= -build/asymmetric/Makefile: MOM_ACFLAGS=--enable-asymmetric +build/asymmetric/Makefile: MOM_ACFLAGS= build/repro/Makefile: MOM_ACFLAGS= build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp build/target/Makefile: MOM_ACFLAGS= diff --git a/ac/configure.ac b/ac/configure.ac index 9a634c1255..1c10c14495 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -39,14 +39,30 @@ AC_CONFIG_MACRO_DIR([m4]) srcdir=$srcdir/.. -# Default to symmetric grid -# NOTE: --enable is more properly used to add a feature, rather than to select -# a compile-time mode, so this is not exactly being used as intended. -MEM_LAYOUT=${srcdir}/config_src/memory/dynamic_symmetric -AC_ARG_ENABLE([asymmetric], - AS_HELP_STRING([--enable-asymmetric], [Use the asymmetric grid])) -AS_IF([test "$enable_asymmetric" = yes], - [MEM_LAYOUT=${srcdir}/config_src/memory/dynamic_nonsymmetric]) +# Configure the memory layout header + +AC_ARG_VAR([MOM_MEMORY], + [Path to MOM_memory.h header, describing the field memory layout: dynamic + symmetric (default), dynamic asymmetric, or static.] +) + +AS_VAR_IF([MOM_MEMORY], [], + [MOM_MEMORY=${srcdir}/config_src/memory/dynamic_symmetric/MOM_memory.h] +) + +# Confirm that MOM_MEMORY is named 'MOM_memory.h' +AS_IF([test $(basename "${MOM_MEMORY}") == "MOM_memory.h"], [], + [AC_MSG_ERROR([MOM_MEMORY header ${MOM_MEMORY} must be named 'MOM_memory.h'])] +) + +# Confirm that the file exists +AC_CHECK_FILE(["$MOM_MEMORY"], [], + [AC_MSG_ERROR([MOM_MEMORY header ${MOM_MEMORY} not found.])] +) + +MOM_MEMORY_DIR=$(AS_DIRNAME(["${MOM_MEMORY}"])) +AC_SUBST([MOM_MEMORY_DIR]) + # Default to solo_driver DRIVER_DIR=${srcdir}/config_src/drivers/solo_driver @@ -234,8 +250,12 @@ AC_SUBST([MAKEDEP]) # Generate source list and configure dependency command -AC_SUBST([SRC_DIRS], - ["${srcdir}/src ${MODEL_FRAMEWORK} ${srcdir}/config_src/external ${DRIVER_DIR} ${MEM_LAYOUT}"] +AC_SUBST([SRC_DIRS], ["\\ + ${srcdir}/src \\ + ${MODEL_FRAMEWORK} \\ + ${srcdir}/config_src/external \\ + ${DRIVER_DIR} \\ + ${MOM_MEMORY_DIR}"] ) AC_CONFIG_COMMANDS(Makefile.dep, [make depend]) From b32b2ed7ad33bc1d622f4421adc219eafb70d7bd Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 20 Apr 2023 22:01:17 -0400 Subject: [PATCH 82/91] Profiling: subparameter parser support The very crude MOM_input parser in the automatic profiler did not support subparameters (e.g. MLE% ... %MLE), which caused an error when trying to read the FMS clock output. This patch adds the support, or at least enough support to avoid errors. --- .testing/Makefile | 3 +- .testing/tools/parse_fms_clocks.py | 54 +++++++++++++++++++++++++----- 2 files changed, 48 insertions(+), 9 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index a28bcc4bc4..b877ecb5f2 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -733,7 +733,8 @@ prof.p0: $(WORKSPACE)/work/p0/opt/clocks.json $(WORKSPACE)/work/p0/opt_target/cl python tools/compare_clocks.py $^ $(WORKSPACE)/work/p0/%/clocks.json: $(WORKSPACE)/work/p0/%/std.out - python tools/parse_fms_clocks.py -d $(@D) $^ > $@ + python tools/parse_fms_clocks.py -d $(@D) $^ > $@ \ + || !( rm $@ ) $(WORKSPACE)/work/p0/opt/std.out: build/opt/MOM6 $(WORKSPACE)/work/p0/opt_target/std.out: build/opt_target/MOM6 diff --git a/.testing/tools/parse_fms_clocks.py b/.testing/tools/parse_fms_clocks.py index b57fc481ab..fd3e7179d7 100755 --- a/.testing/tools/parse_fms_clocks.py +++ b/.testing/tools/parse_fms_clocks.py @@ -60,23 +60,61 @@ def main(): print(json.dumps(config)) -def parse_mom6_param(param_file): +def parse_mom6_param(param_file, header=None): + """Parse a MOM6 input file and return its contents. + + param_file: Path to MOM input file. + header: Optional argument indicating current subparameter block. + """ params = {} for line in param_file: + # Remove any trailing comments from the line. + # NOTE: Exotic values containing `!` will behave unexpectedly. param_stmt = line.split('!')[0].strip() - if param_stmt: - key, val = [s.strip() for s in param_stmt.split('=')] - # TODO: Convert to equivalent Python types - if val in ('True', 'False'): - params[key] = bool(val) - else: - params[key] = val + # Skip blank lines + if not param_stmt: + continue + + if param_stmt[-1] == '%': + # Set up a subparameter block which returns its own dict. + + # Extract the (potentially nested) subparameter: [...%]param% + key = param_stmt.split('%')[-2] + + # Construct subparameter endline: %param[%...] + subheader = key + if header: + subheader = header + '%' + subheader + + # Parse the subparameter contents and return as a dict. + value = parse_mom6_param(param_file, header=subheader) + + elif header and param_stmt == '%' + header: + # Finalize the current subparameter block. + break + + else: + # Extract record from `key = value` entry + # NOTE: Exotic values containing `=` will behave unexpectedly. + key, value = [s.strip() for s in param_stmt.split('=')] + + if value in ('True', 'False'): + # Boolean values are converted into Python logicals. + params[key] = bool(value) + else: + # All other values are currently stored as strings. + params[key] = value return params def parse_clocks(log): + """Parse the FMS time stats from MOM6 output log and return as a dict. + + log: Path to file containing MOM6 stdout. + """ + clock_start_msg = 'Tabulating mpp_clock statistics across' clock_end_msg = 'MPP_STACK high water mark=' From 53e936153c717c63e56a47b92f75b980537080e7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 14 May 2023 07:16:04 -0400 Subject: [PATCH 83/91] +*Redefine GV%Angstrom_H in non-Boussinesq mode Redefined GV%Angstrom_H in non-Boussinesq mode so that it is equal to GV%H_to_Z*GV%Angstrom_Z, just as it is in Boussinesq mode. This will change answers (slightly) in all cases with BOUSSINESQ = False. In addition, this commit adds the elements semi_Boussinesq, dZ_subroundoff, m2_s_to_HZ_T, HZ_T_to_m2_s and HZ_T_to_MKS to the verticalGrid_type. The first 3 new elements are used in rescaling vertical viscosities and diffusivities. The last two elements are set using the new runtime parameters SEMI_BOUSSINESQ and RHO_KV_CONVERT, which are only used or logged when BOUSSINESQ = False. All answers and output are identical in Boussinesq cases, but answers change and there are new runtime parameters in non-Boussinesq cases. --- src/core/MOM_verticalGrid.F90 | 55 +++++++++++++++++++++++++++++++---- 1 file changed, 49 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index d6003ca626..5e9b5c476c 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -41,12 +41,18 @@ module MOM_verticalGrid ! The following variables give information about the vertical grid. logical :: Boussinesq !< If true, make the Boussinesq approximation. + logical :: semi_Boussinesq !< If true, do non-Boussinesq pressure force calculations and + !! use mass-based "thicknesses, but use Rho0 to convert layer thicknesses + !! into certain height changes. This only applies if BOUSSINESQ is false. real :: Angstrom_H !< A one-Angstrom thickness in the model thickness units [H ~> m or kg m-2]. real :: Angstrom_Z !< A one-Angstrom thickness in the model depth units [Z ~> m]. real :: Angstrom_m !< A one-Angstrom thickness [m]. real :: H_subroundoff !< A thickness that is so small that it can be added to a thickness of !! Angstrom or larger without changing it at the bit level [H ~> m or kg m-2]. !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. + real :: dZ_subroundoff !< A thickness in height units that is so small that it can be added to a + !! vertical distance of Angstrom_Z or 1e-17 m without changing it at the bit + !! level [Z ~> m]. This is the height equivalent of H_subroundoff. real, allocatable, dimension(:) :: & g_prime, & !< The reduced gravity at each interface [L2 Z-1 T-2 ~> m s-2]. Rlay !< The target coordinate value (potential density) in each layer [R ~> kg m-3]. @@ -74,8 +80,17 @@ module MOM_verticalGrid !! thickness units [H R-1 Z-1 ~> m3 kg-2 or 1]. real :: H_to_MKS !< A constant that translates thickness units to its MKS unit !! (m or kg m-2) based on GV%Boussinesq [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] + real :: m2_s_to_HZ_T !< The combination of conversion factors that converts kinematic viscosities + !! in m2 s-1 to the internal units of the kinematic (in Boussinesq mode) + !! or dynamic viscosity [H Z s T-1 m-2 ~> 1 or kg m-3] + real :: HZ_T_to_m2_s !< The combination of conversion factors that converts the viscosities from + !! their internal representation into a kinematic viscosity in m2 s-1 + !! [T m2 H-1 Z-1 s-1 ~> 1 or m3 kg-1] + real :: HZ_T_to_MKS !< The combination of conversion factors that converts the viscosities from + !! their internal representation into their unnscaled MKS units + !! (m2 s-1 or Pa s), depending on whether the model is Boussinesq + !! [T m2 H-1 Z-1 s-1 ~> 1] or [T Pa s H-1 Z-1 ~> 1] - real :: m_to_H_restart = 1.0 !< A copy of the m_to_H that is used in restart files. end type verticalGrid_type contains @@ -91,6 +106,8 @@ subroutine verticalGridInit( param_file, GV, US ) ! Local variables integer :: nk, H_power real :: H_rescale_factor ! The integer power of 2 by which thicknesses are rescaled [nondim] + real :: rho_Kv ! The density used convert input kinematic viscosities into dynamic viscosities + ! when in non-Boussinesq mode [R ~> kg m-3] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=16) :: mdl = 'MOM_verticalGrid' @@ -114,6 +131,17 @@ subroutine verticalGridInit( param_file, GV, US ) units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "BOUSSINESQ", GV%Boussinesq, & "If true, make the Boussinesq approximation.", default=.true.) + call get_param(param_file, mdl, "SEMI_BOUSSINESQ", GV%semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=GV%Boussinesq) + if (GV%Boussinesq) GV%semi_Boussinesq = .true. + call get_param(param_file, mdl, "RHO_KV_CONVERT", Rho_Kv, & + "The density used to convert input kinematic viscosities into dynamic "//& + "viscosities in non-BOUSSINESQ mode, and similarly for vertical diffusivities.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=GV%Boussinesq) call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_Z, & "The minimum layer thickness, usually one-Angstrom.", & units="m", default=1.0e-10, scale=US%m_to_Z) @@ -156,26 +184,41 @@ subroutine verticalGridInit( param_file, GV, US ) GV%H_to_kg_m2 = US%R_to_kg_m3*GV%Rho0 * GV%H_to_m GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = 1.0 / GV%H_to_m - GV%Angstrom_H = GV%m_to_H * US%Z_to_m*GV%Angstrom_Z GV%H_to_MKS = GV%H_to_m + GV%m2_s_to_HZ_T = GV%m_to_H * US%m_to_Z * US%T_to_s else GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H GV%H_to_m = GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) - GV%Angstrom_H = US%Z_to_m*GV%Angstrom_Z * 1000.0*GV%kg_m2_to_H GV%H_to_MKS = GV%H_to_kg_m2 + GV%m2_s_to_HZ_T = US%R_to_kg_m3*rho_Kv * GV%kg_m2_to_H * US%m_to_Z * US%T_to_s endif - GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H,GV%m_to_H*1e-17) - GV%H_to_Pa = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth * GV%H_to_kg_m2 GV%H_to_Z = GV%H_to_m * US%m_to_Z GV%Z_to_H = US%Z_to_m * GV%m_to_H + + GV%Angstrom_H = GV%Z_to_H * GV%Angstrom_Z GV%Angstrom_m = US%Z_to_m * GV%Angstrom_Z + GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H, GV%m_to_H*1e-17) + GV%dZ_subroundoff = 1e-20 * max(GV%Angstrom_Z, US%m_to_Z*1e-17) + + GV%H_to_Pa = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth * GV%H_to_kg_m2 + GV%H_to_RZ = GV%H_to_kg_m2 * US%kg_m3_to_R * US%m_to_Z GV%RZ_to_H = GV%kg_m2_to_H * US%R_to_kg_m3 * US%Z_to_m -! Log derivative values. + GV%HZ_T_to_m2_s = 1.0 / GV%m2_s_to_HZ_T + GV%HZ_T_to_MKS = GV%H_to_MKS * US%Z_to_m * US%s_to_T + + ! Note based on the above that for both Boussinsq and non-Boussinesq cases that: + ! GV%Rho0 = GV%Z_to_H * GV%H_to_RZ + ! 1.0/GV%Rho0 = GV%H_to_Z * GV%RZ_to_H + ! This is exact for power-of-2 scaling of the units, regardless of the value of Rho0, but + ! the first term on the right hand side is invertable in Boussinesq mode, but the second + ! is invertable when non-Boussinesq. + + ! Log derivative values. call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*H_rescale_factor, units="H m-1") call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H, units="2^n H m-1") call log_param(param_file, mdl, "THICKNESS to M rescaled by 2^n", GV%H_to_m, units="2^-n m H-1") From 1faa9ab08ff5bb6594b0c719afc7e3b56eab7966 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 17 May 2023 14:48:51 -0400 Subject: [PATCH 84/91] +Set_interp_answer_date and REGRIDDING_ANSWER_DATE Add the ability to set the answer date for the regridding code, including the addition of the new subroutine set_interp_answer_date and the new runtime parameter REGRIDDING_ANSWER_DATE to specify the code vintage to use with state- dependent vertical coordinates. There is also new optional argument to set_regrid_params. By default, all answers are bitwise identical, but there are new or modified public interfaces and there is a new entry in some MOM_parameter_doc files. --- src/ALE/MOM_regridding.F90 | 14 ++++++++++++-- src/ALE/regrid_interp.F90 | 17 ++++++++++++----- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 74b7bc784a..9da4e95b24 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -23,7 +23,7 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE -use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap +use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap, set_interp_answer_date use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike use coord_sigma, only : init_coord_sigma, sigma_CS, set_sigma_params, build_sigma_column, end_coord_sigma @@ -212,6 +212,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the remapping expressions to use. + integer :: regrid_answer_date ! The vintage of the regridding expressions to use. real :: tmpReal, P_Ref real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha @@ -291,6 +292,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& "latter takes precedence.", default=default_answer_date) call set_regrid_params(CS, remap_answer_date=remap_answer_date) + call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, & + "The vintage of the expressions and order of arithmetic to use for regridding. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=20181231) ! ### change to default=default_answer_date) + call set_regrid_params(CS, regrid_answer_date=regrid_answer_date) endif if (main_parameters .and. coord_is_state_dependent) then @@ -2233,7 +2241,7 @@ end function getCoordinateShortName subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_grid_weight, & interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & compress_fraction, ref_pressure, & - integrate_downward_for_e, remap_answers_2018, remap_answer_date, & + integrate_downward_for_e, remap_answers_2018, remap_answer_date, regrid_answer_date, & adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) type(regridding_CS), intent(inout) :: CS !< Regridding control structure logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells @@ -2252,6 +2260,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. integer, optional, intent(in) :: remap_answer_date !< The vintage of the expressions to use for remapping + integer, optional, intent(in) :: regrid_answer_date !< The vintage of the expressions to use for regridding real, optional, intent(in) :: adaptTimeRatio !< Ratio of the ALE timestep to the grid timescale [nondim]. real, optional, intent(in) :: adaptZoom !< Depth of near-surface zooming region [H ~> m or kg m-2]. real, optional, intent(in) :: adaptZoomCoeff !< Coefficient of near-surface zooming diffusivity [nondim]. @@ -2265,6 +2274,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(interp_scheme)) call set_interp_scheme(CS%interp_CS, interp_scheme) if (present(boundary_extrapolation)) call set_interp_extrap(CS%interp_CS, boundary_extrapolation) + if (present(regrid_answer_date)) call set_interp_answer_date(CS%interp_CS, regrid_answer_date) if (present(old_grid_weight)) then if (old_grid_weight<0. .or. old_grid_weight>1.) & diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index e119ce9d53..641ae7e6c2 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -33,14 +33,12 @@ module regrid_interp !! boundary cells logical :: boundary_extrapolation - !> The vintage of the expressions to use for remapping - integer :: answer_date = 20181231 - !### Changing this to 99991231 changes answers in rho and Hycom1 configurations. - !### There is no point where the value of answer_date is reset. + !> The vintage of the expressions to use for regridding + integer :: answer_date = 99991231 end type interp_CS_type public regridding_set_ppolys, build_and_interpolate_grid -public set_interp_scheme, set_interp_extrap +public set_interp_scheme, set_interp_extrap, set_interp_answer_date ! List of interpolation schemes integer, parameter :: INTERPOLATION_P1M_H2 = 0 !< O(h^2) @@ -547,4 +545,13 @@ subroutine set_interp_extrap(CS, extrap) CS%boundary_extrapolation = extrap end subroutine set_interp_extrap +!> Store the value of the answer_date in the interp_CS +subroutine set_interp_answer_date(CS, answer_date) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + integer, intent(in) :: answer_date !< An integer encoding the vintage of + !! the expressions to use for regridding + + CS%answer_date = answer_date +end subroutine set_interp_answer_date + end module regrid_interp From e672b981b08c2e7af8f165122ba40bc10f4b4d19 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 25 May 2023 20:10:01 -0400 Subject: [PATCH 85/91] *+Revise non-Boussinesq find_coupling_coef calcs Restructure one of the find_coupling_coef calculations to draw out the stress-magnitude terms, in preparation for future steps to reduce the dependency on the Boussinesq reference density. Using a value of VERT_FRICTION_ANSWER_DATE that is below 20230601 recovers the previous answers with non-Boussinesq test cases, but this is irrelevant for Boussinesq test cases. This updated code is mathematically equivalent to the previous expressions but it does change answers at roundoff in non-Boussinesq cases for recent answer dates. There are modifications to some comments in MOM_parameter_doc files. --- .../vertical/MOM_vert_friction.F90 | 20 +++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index ea6c7f112b..80fff62f21 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -139,8 +139,11 @@ module MOM_vert_friction integer :: answer_date !< The vintage of the order of arithmetic and expressions in the viscous !! calculations. Values below 20190101 recover the answers from the end !! of 2018, while higher values use expressions that do not use an - !! arbitrary and hard-coded maximum viscous coupling coefficient - !! between layers. + !! arbitrary and hard-coded maximum viscous coupling coefficient between + !! layers. In non-Boussinesq cases, values below 20230601 recover a + !! form of the viscosity within the mixed layer that breaks up the + !! magnitude of the wind stress with BULKMIXEDLAYER, DYNAMIC_VISCOUS_ML + !! or FIXED_DEPTH_LOTW_ML, but not LOTW_VISCOUS_ML_FLOOR. logical :: debug !< If true, write verbose checksums for debugging purposes. integer :: nkml !< The number of layers in the mixed layer. integer, pointer :: ntrunc !< The number of times the velocity has been @@ -1516,6 +1519,8 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, real, dimension(SZIB_(G)) :: & u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1]. + tau_mag, & ! The magnitude of the wind stress at a velocity point including gustiness, + ! divided by the Boussinesq refernce density [Z2 T-2 ~> m2 s-2] absf, & ! The average of the neighboring absolute values of f [T-1 ~> s-1]. ! h_ml, & ! The mixed layer depth [H ~> m or kg m-2]. z_t, & ! The distance from the top, sometimes normalized @@ -1888,7 +1893,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) ! and be further limited by rotation to give the natural Ekman length. - visc_ml = u_star(i) * CS%vonKar * (temp1*u_star(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then + visc_ml = u_star(i) * CS%vonKar * (temp1*u_star(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + tau_mag(i) = u_star(i)**2 + visc_ml = CS%vonKar * (temp1*tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) * GV%H_to_Z + 0.5*I_amax*visc_ml) ! Choose the largest estimate of a_cpl, but these could be changed to be additive. @@ -2180,7 +2190,9 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "The vintage of the order of arithmetic and expressions in the viscous "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use expressions that do not use an arbitrary hard-coded "//& - "maximum viscous coupling coefficient between layers. "//& + "maximum viscous coupling coefficient between layers. Values below 20230601 "//& + "recover a form of the viscosity within the mixed layer that breaks up the "//& + "magnitude of the wind stress in some non-Boussinesq cases. "//& "If both VERT_FRICTION_2018_ANSWERS and VERT_FRICTION_ANSWER_DATE are "//& "specified, the latter takes precedence.", default=default_answer_date) From edb22ec5825c315b5498d3b5064b1af3175dd714 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 29 Apr 2023 11:00:54 -0400 Subject: [PATCH 86/91] +Code to calculate layer averaged specific volumes Add routines to calculate and store the layer-averaged specific volume, along with code to do the unit testing of this new capability. The new public interfaces include avg_specific_vol, average_specific_vol, avg_spec_vol_Wright, avg_spec_vol_Wright_full, avg_spec_vol_Wright_red and avg_spec_vol_linear. There is also a new optional argument to test_EOS_consistency to control whether these new capabilties are tested for a particular equation of state. All answers are bitwise identical, and the new capabilities pass the unit testing for self consistency. --- src/core/MOM_density_integrals.F90 | 34 ++++- src/equation_of_state/MOM_EOS.F90 | 144 ++++++++++++++++-- src/equation_of_state/MOM_EOS_Wright.F90 | 39 ++++- src/equation_of_state/MOM_EOS_Wright_full.F90 | 38 +++++ src/equation_of_state/MOM_EOS_Wright_red.F90 | 38 +++++ src/equation_of_state/MOM_EOS_linear.F90 | 26 +++- 6 files changed, 307 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index e1fb3d3278..9fed528e71 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -4,12 +4,13 @@ module MOM_density_integrals ! This file is part of MOM6. See LICENSE.md for the license. use MOM_EOS, only : EOS_type -use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : EOS_quadrature, EOS_domain use MOM_EOS, only : analytic_int_density_dz use MOM_EOS, only : analytic_int_specific_vol_dp use MOM_EOS, only : calculate_density use MOM_EOS, only : calculate_spec_vol use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_EOS, only : average_specific_vol use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_hor_index, only : hor_index_type use MOM_string_functions, only : uppercase @@ -28,6 +29,7 @@ module MOM_density_integrals public int_specific_vol_dp public int_spec_vol_dp_generic_pcm public int_spec_vol_dp_generic_plm +public avg_specific_vol public find_depth_of_pressure_in_cell contains @@ -1613,6 +1615,36 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t end subroutine find_depth_of_pressure_in_cell +!> Calculate the average in situ specific volume across layers +subroutine avg_specific_vol(T, S, p_t, dp, HI, EOS, SpV_avg, halo_size) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: dp !< Pressure change in the layer [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [R-1 ~> m3 kg-1] + integer, optional, intent(in) :: halo_size !< The number of halo points in which to work. + + ! Local variables + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: jsh, jeh, j, halo + + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + jsh = HI%jsc-halo ; jeh = HI%jec+halo + + EOSdom(:) = EOS_domain(HI, halo_size) + do j=jsh,jeh + call average_specific_vol(T(:,j), S(:,j), p_t(:,j), dp(:,j), SpV_avg(:,j), EOS, EOSdom) + enddo + +end subroutine avg_specific_vol !> Returns change in anomalous pressure change from top to non-dimensional !! position pos between z_t and z_b [R L2 T-2 ~> Pa] diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 276c4c3019..c68dc7b661 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -8,24 +8,25 @@ module MOM_EOS use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear use MOM_EOS_linear, only : calculate_density_second_derivs_linear, EoS_fit_range_linear use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear +use MOM_EOS_linear, only : avg_spec_vol_linear use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright use MOM_EOS_Wright, only : calculate_density_derivs_wright use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright use MOM_EOS_Wright, only : calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy -use MOM_EOS_Wright, only : EoS_fit_range_Wright +use MOM_EOS_Wright, only : EoS_fit_range_Wright, avg_spec_vol_Wright use MOM_EOS_Wright_full, only : calculate_density_wright_full, calculate_spec_vol_wright_full use MOM_EOS_Wright_full, only : calculate_density_derivs_wright_full use MOM_EOS_Wright_full, only : calculate_specvol_derivs_wright_full, int_density_dz_wright_full use MOM_EOS_Wright_full, only : calculate_compress_wright_full, int_spec_vol_dp_wright_full use MOM_EOS_Wright_full, only : calculate_density_second_derivs_wright_full -use MOM_EOS_Wright_full, only : EoS_fit_range_Wright_full +use MOM_EOS_Wright_full, only : EoS_fit_range_Wright_full, avg_spec_vol_Wright_full use MOM_EOS_Wright_red, only : calculate_density_wright_red, calculate_spec_vol_wright_red use MOM_EOS_Wright_red, only : calculate_density_derivs_wright_red use MOM_EOS_Wright_red, only : calculate_specvol_derivs_wright_red, int_density_dz_wright_red use MOM_EOS_Wright_red, only : calculate_compress_wright_red, int_spec_vol_dp_wright_red use MOM_EOS_Wright_red, only : calculate_density_second_derivs_wright_red -use MOM_EOS_Wright_red, only : EoS_fit_range_Wright_red +use MOM_EOS_Wright_red, only : EoS_fit_range_Wright_red, avg_spec_vol_Wright_red use MOM_EOS_Jackett06, only : calculate_density_Jackett06, calculate_spec_vol_Jackett06 use MOM_EOS_Jackett06, only : calculate_density_derivs_Jackett06, calculate_specvol_derivs_Jackett06 use MOM_EOS_Jackett06, only : calculate_compress_Jackett06, calculate_density_second_derivs_Jackett06 @@ -68,6 +69,7 @@ module MOM_EOS public EOS_unit_tests public analytic_int_density_dz public analytic_int_specific_vol_dp +public average_specific_vol public calculate_compress public calculate_density public calculate_density_derivs @@ -1324,6 +1326,97 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) end subroutine calculate_compress_scalar +!> Calls the appropriate subroutine to calculate the layer averaged specific volume either using +!! Boole's rule quadrature or analytical and nearly-analytical averages in pressure. +subroutine average_specific_vol(T, S, p_t, dp, SpV_avg, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [R-1 ~> m3 kg-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale + !! output specific volume in combination with + !! scaling stored in EOS [various] + + ! Local variables + real, dimension(size(T)) :: pres ! Layer-top pressure converted to [Pa] + real, dimension(size(T)) :: dpres ! Pressure change converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + real :: T5(5) ! Temperatures at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + integer :: i, n, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(T) ; npts = 1 + ie - is + endif + + if (EOS%EOS_quadrature) then + do i=is,ie + do n=1,5 + T5(n) = T(i) ; S5(n) = S(i) + p5(n) = p_t(i) + 0.25*real(5-n)*dp(i) + enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS) + + ! Use Boole's rule to estimate the average specific volume. + SpV_avg(i) = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + enddo + elseif ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, is, npts, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS) + case (EOS_WRIGHT) + call avg_spec_vol_wright(T, S, p_t, dp, SpV_avg, is, npts) + case (EOS_WRIGHT_FULL) + call avg_spec_vol_wright_full(T, S, p_t, dp, SpV_avg, is, npts) + case (EOS_WRIGHT_REDUCED) + call avg_spec_vol_wright_red(T, S, p_t, dp, SpV_avg, is, npts) + case default + call MOM_error(FATAL, "No analytic average specific volume option is available with this EOS!") + end select + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * p_t(i) + dpres(i) = EOS%RL2_T2_to_Pa * dp(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call avg_spec_vol_linear(Ta, Sa, pres, dpres, SpV_avg, is, npts, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS) + case (EOS_WRIGHT) + call avg_spec_vol_wright(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case (EOS_WRIGHT_FULL) + call avg_spec_vol_wright_full(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case (EOS_WRIGHT_REDUCED) + call avg_spec_vol_wright_red(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case default + call MOM_error(FATAL, "No analytic average specific volume option is available with this EOS!") + end select + endif + + spv_scale = EOS%R_to_kg_m3 + if (EOS%EOS_quadrature) spv_scale = 1.0 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do i=is,ie + SpV_avg(i) = spv_scale * SpV_avg(i) + enddo ; endif + +end subroutine average_specific_vol + !> Return the range of temperatures, salinities and pressures for which the equation of state that !! is being used has been fitted to observations. Care should be taken when applying !! this equation of state outside of its fit range. @@ -2057,13 +2150,13 @@ logical function EOS_unit_tests(verbose) call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_FULL) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_FULL", & - rho_check=1027.55177447616*EOS_tmp%kg_m3_to_R) + rho_check=1027.55177447616*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_FULL EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_REDUCED) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_REDUCED", & - rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R) + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_REDUCED EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail @@ -2076,7 +2169,7 @@ logical function EOS_unit_tests(verbose) call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & - rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R) + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail @@ -2126,7 +2219,7 @@ logical function EOS_unit_tests(verbose) call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", & - rho_check=1023.0*EOS_tmp%kg_m3_to_R) + rho_check=1023.0*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) if (verbose .and. fail) call MOM_error(WARNING, "LINEAR EOS has failed some self-consistency tests.") EOS_unit_tests = EOS_unit_tests .or. fail @@ -2293,7 +2386,7 @@ end subroutine write_check_msg !> Test an equation of state for self-consistency and consistency with check values, returning false !! if it is consistent by all tests, and true if it fails any test. logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & - EOS_name, rho_check, spv_check, skip_2nd) result(inconsistent) + EOS_name, rho_check, spv_check, skip_2nd, avg_Sv_check) result(inconsistent) real, intent(in) :: T_test !< Potential temperature or conservative temperature [C ~> degC] real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] @@ -2302,7 +2395,9 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & character(len=*), intent(in) :: EOS_name !< A name used in error messages to describe the EoS real, optional, intent(in) :: rho_check !< A check value for the density [R ~> kg m-3] real, optional, intent(in) :: spv_check !< A check value for the specific volume [R-1 ~> m3 kg-1] - logical, optional, intent(in) :: skip_2nd !< If present and true, do not check the 2nd derivatives. + logical, optional, intent(in) :: skip_2nd !< If present and true, do not check the 2nd derivatives. + logical, optional, intent(in) :: avg_Sv_check !< If present and true, compare analytical and numerical + !! quadrature estimates of the layer-averaged specific volume. ! Local variables real, dimension(-3:3,-3:3,-3:3) :: T ! Temperatures at the test value and perturbed points [C ~> degC] @@ -2329,6 +2424,8 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & ! temperature [R-1 C-1 ~> m3 kg-1 degC-1] real :: dSV_dS(1) ! The partial derivative of specific volume with salinity ! [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: SpV_avg_a(1) ! The pressure-averaged specific volume determined analytically [R-1 ~> m3 kg-1] + real :: SpV_avg_q(1) ! The pressure-averaged specific volume determined via quadrature [R-1 ~> m3 kg-1] real :: drho_dS_dS ! Second derivative of density with respect to S [R S-2 ~> kg m-3 ppt-2] real :: drho_dS_dT ! Second derivative of density with respect to T and S [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] real :: drho_dT_dT ! Second derivative of density with respect to T [R C-2 ~> kg m-3 degC-2] @@ -2370,13 +2467,17 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & real :: count_fac2 ! A factor in the roundoff estimates based on the factors in the numerator and ! denominator in the finite difference second derivative expression [nondim] character(len=200) :: mesg + type(EOS_type) :: EOS_tmp logical :: test_OK ! True if a particular test is consistent. logical :: OK ! True if all checks so far are consistent. logical :: test_2nd ! If true, do tests on the 2nd derivative calculations + logical :: test_avg_Sv ! If true, compare numerical and analytical estimates of the vertically + ! averaged specific volume integer :: order ! The order of accuracy of the centered finite difference estimates (2, 4 or 6). integer :: i, j, k, n test_2nd = .true. ; if (present(skip_2nd)) test_2nd = .not.skip_2nd + test_avg_Sv = .false. ; if (present(avg_Sv_check)) test_avg_Sv = avg_Sv_check dT = 0.1*EOS%degC_to_C ! Temperature perturbations [C ~> degC] dS = 0.5*EOS%ppt_to_S ! Salinity perturbations [S ~> ppt] @@ -2442,6 +2543,14 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, EOS) call calculate_compress(T(0,0,0), S(0,0,0), p(0,0,0), rho_tmp, drho_dp, EOS) + if (test_avg_Sv) then + EOS_tmp = EOS + call EOS_manual_init(EOS_tmp, EOS_quadrature=.false.) + call average_specific_vol(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), p(0:0,0,0), SpV_avg_a, EOS_tmp) + call EOS_manual_init(EOS_tmp, EOS_quadrature=.true.) + call average_specific_vol(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), p(0:0,0,0), SpV_avg_q, EOS_tmp) + endif + OK = .true. tol = 1000.0*epsilon(tol) @@ -2532,6 +2641,23 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & OK = OK .and. check_FD(drho_dS_dP, drho_dS_dP_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dP", order) endif + if (test_avg_Sv) then + tol_here = 0.5*tol*(abs(SpV_avg_a(1)) + abs(SpV_avg_q(1))) + test_OK = (abs(SpV_avg_a(1) - SpV_avg_q(1)) < tol_here) + if (verbose) then + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2"), tol=",ES16.8)') & + SpV_avg_a(1), SpV_avg_q(1), SpV_avg_a(1) - SpV_avg_q(1), & + 2.0*(SpV_avg_a(1) - SpV_avg_q(1)) / (abs(SpV_avg_a(1)) + abs(SpV_avg_q(1)) + tiny(SpV_avg_a(1))), & + tol_here + if (verbose .and. .not.test_OK) then + call MOM_error(WARNING, "The values of "//trim(EOS_name)//" SpV_avg disagree. "//trim(mesg)) + elseif (verbose) then + call MOM_mesg("The values of "//trim(EOS_name)//" SpV_avg agree: "//trim(mesg)) + endif + endif + OK = OK .and. test_OK + endif + inconsistent = .not.OK contains diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 25ae9219a8..d8dee28aa2 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -10,7 +10,7 @@ module MOM_EOS_Wright public calculate_compress_wright, calculate_density_wright, calculate_spec_vol_wright public calculate_density_derivs_wright, calculate_specvol_derivs_wright public calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy -public EoS_fit_range_Wright +public EoS_fit_range_Wright, avg_spec_vol_Wright public int_density_dz_wright, int_spec_vol_dp_wright !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to @@ -547,6 +547,42 @@ subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) enddo end subroutine calculate_compress_wright +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_Wright(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha(j) = al0 + lambda / (pressure(j) + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo +end subroutine avg_spec_vol_Wright + !> Return the range of temperatures, salinities and pressures for which the reduced-range equation !! of state from Wright (1997) has been fitted to observations. Care should be taken when applying !! this equation of state outside of its fit range. @@ -1066,6 +1102,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_wright + !> \namespace mom_eos_wright !! !! \section section_EOS_Wright Wright equation of state diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 index 3f00a92cef..107ced3f5b 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -11,6 +11,7 @@ module MOM_EOS_Wright_full public calculate_density_derivs_wright_full, calculate_specvol_derivs_wright_full public calculate_density_second_derivs_wright_full, EoS_fit_range_Wright_full public int_density_dz_wright_full, int_spec_vol_dp_wright_full +public avg_spec_vol_Wright_full !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity in practical salinity units ([PSU]), potential @@ -450,6 +451,42 @@ subroutine calculate_compress_wright_full(T, S, pressure, rho, drho_dp, start, n enddo end subroutine calculate_compress_wright_full +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_Wright_full(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha(j) = al0 + lambda / (pressure(j) + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo +end subroutine avg_spec_vol_Wright_full + !> Return the range of temperatures, salinities and pressures for which full-range equation !! of state from Wright (1997) has been fitted to observations. Care should be taken when applying !! this equation of state outside of its fit range. @@ -972,6 +1009,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_wright_full + !> \namespace mom_eos_wright_full !! !! \section section_EOS_Wright_full Wright equation of state diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 index cf78ce2211..5553112274 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -11,6 +11,7 @@ module MOM_EOS_Wright_red public calculate_density_derivs_wright_red, calculate_specvol_derivs_wright_red public calculate_density_second_derivs_wright_red, EoS_fit_range_Wright_red public int_density_dz_wright_red, int_spec_vol_dp_wright_red +public avg_spec_vol_Wright_red !> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to !! a reference density, from salinity in practical salinity units ([PSU]), potential @@ -450,6 +451,42 @@ subroutine calculate_compress_wright_red(T, S, pressure, rho, drho_dp, start, np enddo end subroutine calculate_compress_wright_red +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_Wright_red(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha(j) = al0 + lambda / (pressure(j) + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo +end subroutine avg_spec_vol_Wright_red + !> Return the range of temperatures, salinities and pressures for which the reduced-range equation !! of state from Wright (1997) has been fitted to observations. Care should be taken when applying !! this equation of state outside of its fit range. @@ -972,6 +1009,7 @@ subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_wright_red + !> \namespace mom_eos_wright_red !! !! \section section_EOS_Wright_red Wright equation of state diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 1899103f5d..b1dacf2780 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -13,6 +13,7 @@ module MOM_EOS_linear public calculate_density_scalar_linear, calculate_density_array_linear public calculate_density_second_derivs_linear, EoS_fit_range_linear public int_density_dz_linear, int_spec_vol_dp_linear +public avg_spec_vol_linear ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -292,7 +293,7 @@ end subroutine calculate_specvol_derivs_linear !> This subroutine computes the in situ density of sea water (rho) !! and the compressibility (drho/dp == C_sound^-2) at the given !! salinity, potential temperature, and pressure. -subroutine calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts,& +subroutine calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts, & Rho_T0_S0, dRho_dT, dRho_dS) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface !! [degC]. @@ -318,6 +319,29 @@ subroutine calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts,& enddo end subroutine calculate_compress_linear +!> Calculates the layer average specific volumes. +subroutine avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, start, npts, Rho_T0_S0, dRho_dT, dRho_dS) + real, dimension(:), intent(in) :: T !< Potential temperature [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] + real, intent(in) :: dRho_dT !< The derivative of density with temperature + !! [kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of density with salinity + !! [kg m-3 ppt-1] + ! Local variables + integer :: j + + do j=start,start+npts-1 + SpV_avg(j) = 1.0 / (Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) + enddo +end subroutine avg_spec_vol_linear + !> Return the range of temperatures, salinities and pressures for which the reduced-range equation !! of state from Wright (1997) has been fitted to observations. Care should be taken when applying !! this equation of state outside of its fit range. From e86b35adfd9bc3828aa9ae66d69d860e04358da7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 29 Apr 2023 11:04:47 -0400 Subject: [PATCH 87/91] +Add thickness_to_dz and calc_derived_thermo Added the new overloaded interface thickness_to_dz to convert the layer thicknesses in thickness units [H ~> m or kg m-2] into vertical distances in [Z ~> m], with variants that set full 3-d arrays or an i-/k- slice. Also added a field (SpV_avg) for the layer-averaged specific volume to the thermo_vars_ptr type and the new subroutine calc_derived_thermo to set it. This new subroutine is being called after halo updates to the temperatures and salinities. The new runtime parameter SEMI_BOUSSINESQ was added to determine whether tv%SpV_avg is allocated and used; it is stored in GV%semi_Boussinesq. Also added the new element GV%dZ_subroundoff to the verticalGrid_type as a counterpart to GV%H_subroundoff but in height units. All answers are bitwise identical, but there is a new runtime parameter in some MOM_parameter_doc files, new elements in a transparent type and a new public interface. --- src/core/MOM.F90 | 42 +++++- src/core/MOM_interface_heights.F90 | 124 +++++++++++++++++- src/core/MOM_variables.F90 | 3 + .../vertical/MOM_diabatic_driver.F90 | 10 +- src/tracer/MOM_offline_main.F90 | 8 ++ 5 files changed, 179 insertions(+), 8 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c61ed72e0c..af8481fd1c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -91,7 +91,7 @@ module MOM use MOM_grid, only : set_first_direction, rescale_grid_bathymetry use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, calc_derived_thermo use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end use MOM_interface_filter, only : interface_filter_CS use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end @@ -1400,6 +1400,12 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + halo_sz = 1 + endif + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz) endif endif @@ -1581,6 +1587,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call create_group_pass(pass_uv_T_S_h, h, G%Domain, halo=dynamics_stencil) call do_group_pass(pass_uv_T_S_h, G%Domain, clock=id_clock_pass) + ! Update derived thermodynamic quantities. + if (allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil) + endif + if (CS%debug .and. CS%use_ALE_algorithm) then call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, scale=US%C_to_degC) @@ -1623,13 +1634,19 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_end(id_clock_adiabatic) if (associated(tv%T)) then - call create_group_pass(pass_T_S, tv%T, G%Domain, To_All+Omit_Corners, halo=1) - call create_group_pass(pass_T_S, tv%S, G%Domain, To_All+Omit_Corners, halo=1) + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_T_S, tv%T, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) + call create_group_pass(pass_T_S, tv%S, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) if (CS%debug) then if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, scale=US%C_to_degC) if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, scale=US%S_to_ppt) endif + + ! Update derived thermodynamic quantities. + if (allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil) + endif endif endif ! endif for the block "if (.not.CS%adiabatic)" @@ -1676,6 +1693,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS type(time_type), pointer :: accumulated_time => NULL() type(time_type), pointer :: vertical_time => NULL() + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz ! 3D pointers @@ -1848,6 +1867,12 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS fluxes%fluxes_used = .true. + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil) + endif + if (last_iter) then accumulated_time = real_to_time(0.0) endif @@ -2817,6 +2842,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif endif + ! Allocate any derived equation of state fields. + if (use_temperature .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + allocate(CS%tv%SpV_avg(isd:ied,jsd:jed,nz), source=0.0) + endif + if (use_ice_shelf .and. CS%debug) then call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0,scale=US%RZ_to_kg_m2) @@ -3103,6 +3133,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call do_group_pass(pass_uv_T_S_h, G%Domain) + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil) + endif + if (associated(CS%visc%Kv_shear)) & call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) @@ -3931,6 +3966,7 @@ subroutine MOM_end(CS) if (associated(CS%Hml)) deallocate(CS%Hml) if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) + if (allocated(CS%tv%SpV_avg)) deallocate(CS%tv%SpV_avg) if (associated(CS%tv%T)) then DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 4f41cb074b..befeb1c2ad 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -3,7 +3,7 @@ module MOM_interface_heights ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_density_integrals, only : int_specific_vol_dp +use MOM_density_integrals, only : int_specific_vol_dp, avg_specific_vol use MOM_error_handler, only : MOM_error, FATAL use MOM_EOS, only : calculate_density, EOS_type, EOS_domain use MOM_file_parser, only : log_version @@ -16,18 +16,26 @@ module MOM_interface_heights #include -public find_eta, dz_to_thickness, dz_to_thickness_simple +public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple +public calc_derived_thermo !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta module procedure find_eta_2d, find_eta_3d end interface find_eta -!> Calculates layer thickness in thickness units from geometric thicknesses in height units. +!> Calculates layer thickness in thickness units from geometric distance between the +!! interfaces around that layer in height units. interface dz_to_thickness module procedure dz_to_thickness_tv, dz_to_thickness_EoS end interface dz_to_thickness +!> Converts layer thickness in thickness units into the vertical distance between the +!! interfaces around a layer in height units. +interface thickness_to_dz + module procedure thickness_to_dz_3d, thickness_to_dz_jslice +end interface thickness_to_dz + contains !> Calculates the heights of all interfaces between layers, using the appropriate @@ -253,6 +261,45 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) end subroutine find_eta_2d +!> Calculate derived thermodynamic quantities for re-use later. +subroutine calc_derived_thermo(tv, h, G, GV, US, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various + !! thermodynamic variables, some of + !! which will be set here. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + integer, optional, intent(in) :: halo !< Width of halo within which to + !! calculate thicknesses + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: p_t ! Hydrostatic pressure atop a layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: dp ! Pressure change across a layer [R L2 T-2 ~> Pa] + integer :: i, j, k, is, ie, js, je, halos, nz + + halos = 0 ; if (present(halo)) halos = max(0,halo) + is = G%isc-halos ; ie = G%iec+halos ; js = G%jsc-halos ; je = G%jec+halos ; nz = GV%ke + + if (allocated(tv%Spv_avg) .and. associated(tv%eqn_of_state)) then + if (associated(tv%p_surf)) then + do j=js,je ; do i=is,ie ; p_t(i,j) = tv%p_surf(i,j) ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; p_t(i,j) = 0.0 ; enddo ; enddo + endif + do k=1,nz + do j=js,je ; do i=is,ie + dp(i,j) = GV%g_Earth*GV%H_to_RZ*h(i,j,k) + enddo ; enddo + call avg_specific_vol(tv%T(:,:,k), tv%S(:,:,k), p_t, dp, G%HI, tv%eqn_of_state, tv%SpV_avg(:,:,k), halo) + if (k Converts thickness from geometric height units to thickness units, perhaps via an !! inversion of the integral of the density in pressure using variables stored in !! the thermo_var_ptrs type when in non-Boussinesq mode. @@ -428,4 +475,75 @@ subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) end subroutine dz_to_thickness_simple +!> Converts layer thicknesses in thickness units to the vertical distance between edges in height +!! units, perhaps by multiplication by the precomputed layer-mean specific volume stored in an +!! array in the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Input thicknesses in thickness units [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz ; do j=js,je ; do i=is,ie + dz(i,j,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + dz(i,j,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo ; enddo + endif + +end subroutine thickness_to_dz_3d + + +!> Converts a vertical i- / k- slice of layer thicknesses in thickness units to the vertical +!! distance between edges in height units, perhaps by multiplication by the precomputed layer-mean +!! specific volume stored in an array in the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine thickness_to_dz_jslice(h, tv, dz, j, G, GV, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Input thicknesses in thickness units [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, intent(in) :: j !< The second (j-) index of the input thicknesses to work with + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + integer :: i, k, is, ie, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; nz = GV%ke + + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz ; do i=is,ie + dz(i,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo + else + do k=1,nz ; do i=is,ie + dz(i,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo + endif + +end subroutine thickness_to_dz_jslice + end module MOM_interface_heights diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 5efb02fe44..bec93376af 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -93,6 +93,9 @@ module MOM_variables logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is !! actually the absolute salinity in units of [gSalt kg-1]. real :: min_salinity !< The minimum value of salinity when BOUND_SALINITY=True [S ~> ppt]. + real, allocatable, dimension(:,:,:) :: SpV_avg + !< The layer averaged in situ specific volume [R-1 ~> m3 kg-1]. + ! These arrays are accumulated fluxes for communication with other components. real, dimension(:,:), pointer :: frazil => NULL() !< The energy needed to heat the ocean column to the diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 59d5aaf60a..0fe08a06b2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -43,7 +43,7 @@ module MOM_diabatic_driver use MOM_grid, only : ocean_grid_type use MOM_int_tide_input, only : set_int_tide_input, int_tide_input_init use MOM_int_tide_input, only : int_tide_input_end, int_tide_input_CS, int_tide_input_type -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, calc_derived_thermo use MOM_internal_tides, only : propagate_int_tide use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used @@ -1844,9 +1844,15 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Also changes: visc%Kd_shear and visc%Kv_shear if ((CS%halo_TS_diff > 0) .and. (CS%ML_mix_first > 0.0)) then if (associated(tv%T)) call pass_var(tv%T, G%Domain, halo=CS%halo_TS_diff, complete=.false.) - if (associated(tv%T)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + if (associated(tv%S)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) endif + + ! Update derived thermodynamic quantities. + if ((CS%ML_mix_first > 0.0) .and. allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=CS%halo_TS_diff) + endif + if (CS%debug) & call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) if (CS%double_diffuse) then diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index ea6167a6b8..40dced9b20 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -22,6 +22,7 @@ module MOM_offline_main use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : calc_derived_thermo use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw @@ -1025,6 +1026,7 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) type(forcing), intent(inout) :: fluxes !< Pointers to forcing fields logical, intent(in ) :: do_ale !< True if using ALE ! Local variables + integer :: stencil integer :: i, j, k, is, ie, js, je, nz real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_start ! Initial thicknesses [H ~> m or kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1086,6 +1088,12 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) call pass_var(CS%tv%T, G%Domain) call pass_var(CS%tv%S, G%Domain) + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, CS%h_end, G, GV, US, halo=stencil) + endif + ! Update the read indices CS%ridx_snap = next_modulo_time(CS%ridx_snap,CS%numtime) CS%ridx_sum = next_modulo_time(CS%ridx_sum,CS%numtime) From e0021fc0679e2896d9466055ea87707fcb76d166 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Fri, 21 Apr 2023 09:35:06 -0400 Subject: [PATCH 88/91] wave structure computation into wave_speeds wave_speeds now computes the wave structures (eigenvectors) for each mode speed (eigenvalue) similarly to the wave_speed (singular) function. This is a replacement for the MOM_wave_structure function, which could be removed in a subsequent PR. Additional arrays for mode strucures and integral quantities are passed as output hence this is a breaking change for the call to wave_speeds. However it is only called once in diabatic_driver and is used exclusively for internal tides ray tracing. The dimensional solutions for the wave structures are now computed inside MOM_internal_tides, and new diagnostics are added. An out-of-bounds bug is also corrected for the computation of an averaged coriolis parameter. --- src/diagnostics/MOM_wave_speed.F90 | 257 ++++++++++++++++-- .../lateral/MOM_internal_tides.F90 | 153 ++++++++++- .../vertical/MOM_diabatic_driver.F90 | 5 +- 3 files changed, 384 insertions(+), 31 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 9c8cd099f3..bb1b381c15 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -7,7 +7,7 @@ module MOM_wave_speed use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : log_version use MOM_grid, only : ocean_grid_type -use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h, interpolate_column use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -651,17 +651,33 @@ subroutine tdma6(n, a, c, lam, y) end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. -subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - integer, intent(in) :: nmodes !< Number of modes - real, dimension(G%isd:G%ied,G%jsd:G%jed,nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] - type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire data domain. +subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_struct_max, u_struct_bot, Nb, int_w2, & + int_U2, int_N2w2, full_halos) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + integer, intent(in) :: nmodes !< Number of modes + type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1,nmodes),intent(out) :: w_struct !< Wave Vertical profile [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),nmodes),intent(out) :: u_struct !< Wave Horizontal profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_max !< Maximum of wave horizontal profile + !! [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_bot !< Bottom value of wave horizontal + !! profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Nb !< Bottom value of Brunt Vaissalla freqency + !! [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_w2 !< depth-integrated + !! vertical profile squared [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_U2 !< depth-integrated + !! horizontal profile squared [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated Brunt Vaissalla + !! frequency times vertical + !! profile squared [Z T-2 ~> m s-2] + logical, optional, intent(in) :: full_halos !< If true, do the calculation + !! over the entire data domain. ! Local variables real, dimension(SZK_(GV)+1) :: & @@ -672,7 +688,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) S_int, & ! Salinity interpolated to interfaces [S ~> ppt] H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] - gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. + gprime, & ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. + N2 ! The Brunt Vaissalla freqency squared [T-2 ~> s-2] real, dimension(SZK_(GV),SZI_(G)) :: & Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] @@ -684,7 +701,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) Hc, & ! A column of layer thicknesses after convective instabilities are removed [Z ~> m] Tc, & ! A column of layer temperatures after convective instabilities are removed [C ~> degC] Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] - Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + Rc, & ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and its ! derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. @@ -737,7 +755,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) real :: tol_merge ! The fractional change in estimated wave speed that is allowed ! when deciding to merge layers in the calculation [nondim] integer :: kf(SZI_(G)) ! The number of active layers after filtering. - integer, parameter :: max_itt = 10 + integer, parameter :: max_itt = 30 logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. logical :: merge ! If true, merge the current layer with the one above. @@ -749,6 +767,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) integer :: kc ! The number of layers in the column after merging integer :: sub, sub_it integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m + real, dimension(SZK_(GV)+1) :: modal_structure !< Normalized model structure [nondim] + real, dimension(SZK_(GV)) :: modal_structure_fder !< Normalized model structure [Z-1 ~> m-1] + real :: mode_struct(SZK_(GV)+1) ! The mode structure [nondim], but it is also temporarily + ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. + real :: mode_struct_fder(SZK_(GV)) ! The mode structure 1st derivative [nondim], but it is also temporarily + ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. + real :: mode_struct_sq(SZK_(GV)+1) ! The square of mode structure [nondim] + real :: mode_struct_fder_sq(SZK_(GV)) ! The square of mode structure 1st derivative [Z-2 ~> m-2] + + + real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] + real :: ms_sq ! The sum of the square of the values returned from tdma6 [L4 T-4 ~> m4 s-4] + real :: w2avg ! A total for renormalization + real, parameter :: a_int = 0.5 ! Integral total for normalization + real :: renorm ! Normalization factor is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -777,9 +810,17 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif cg1_min2 = CS%min_speed2 - ! Zero out all wave speeds. Values over land or for columns that are too weakly stratified + ! Zero out all local values. Values over land or for columns that are too weakly stratified ! are not changed from this zero value. cn(:,:,:) = 0.0 + u_struct_max(:,:,:) = 0.0 + u_struct_bot(:,:,:) = 0.0 + Nb(:,:) = 0.0 + int_w2(:,:,:) = 0.0 + int_N2w2(:,:,:) = 0.0 + int_U2(:,:,:) = 0.0 + u_struct(:,:,:,:) = 0.0 + w_struct(:,:,:,:) = 0.0 min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,CS,min_h_frac,use_EOS, & @@ -1010,8 +1051,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Calculate Igu, Igl, depth, and N2 at each interior interface ! [excludes surface (K=1) and bottom (K=kc+1)] + Igl(:) = 0. + Igu(:) = 0. + N2(:) = 0. + do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) + N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) if (better_est) then speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) else @@ -1019,9 +1065,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif enddo + ! Set stratification for surface and bottom (setting equal to nearest interface for now) + N2(1) = N2(2) ; N2(kc+1) = N2(kc) + ! set bottom stratification + Nb(i,j) = sqrt(N2(kc+1)) + ! Under estimate the first eigenvalue (overestimate the speed) to start with. lam_1 = 1.0 / speed2_tot + ! init and first guess for mode structure + mode_struct(:) = 0. + mode_struct_fder(:) = 0. + mode_struct(2:kc) = 1. ! Uniform flow, first guess + modal_structure(:) = 0. + modal_structure_fder(:) = 0. + ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) @@ -1039,11 +1097,89 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) lam_1 = lam_1 + dlam endif + call tdma6(kc-1, Igu(2:kc), Igl(2:kc), lam_1, mode_struct(2:kc)) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] + ! apply BC + mode_struct(1) = 0. + mode_struct(kc+1) = 0. + + ! renormalization of the integral of the profile + w2avg = 0.0 + do k=1,kc + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) ![Z L4 T-4] + enddo + renorm = sqrt(htot(i)*a_int/w2avg) ![L-2 T-2] + do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo + ! after renorm, mode_struct is again [nondim] + if (abs(dlam) < tol_solve*lam_1) exit enddo if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) + ! sign of wave structure is irrelevant, flip to positive if needed + if (mode_struct(2)<0.) then + mode_struct(2:kc) = -1. * mode_struct(2:kc) + endif + + ! vertical derivative of w at interfaces lives on the layer points + do k=1,kc + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / Hc(k) + enddo + + ! boundary condition for derivative is no-gradient + do k=kc+1,nz + mode_struct_fder(k) = mode_struct_fder(kc) + enddo + + ! now save maximum value and bottom value + u_struct_bot(i,j,1) = mode_struct_fder(kc) + u_struct_max(i,j,1) = maxval(abs(mode_struct_fder(1:kc))) + + ! Calculate terms for vertically integrated energy equation + do k=1,kc + mode_struct_fder_sq(k) = mode_struct_fder(k)**2 + enddo + do K=1,kc+1 + mode_struct_sq(K) = mode_struct(K)**2 + enddo + + ! sum over layers for quantities defined on layer + do k=1,kc + int_U2(i,j,1) = int_U2(i,j,1) + mode_struct_fder_sq(k) * Hc(k) + enddo + + ! vertical integration with Trapezoidal rule for values at interfaces + do K=1,kc + int_w2(i,j,1) = int_w2(i,j,1) + 0.5*(mode_struct_sq(K)+mode_struct_sq(K+1)) * Hc(k) + int_N2w2(i,j,1) = int_N2w2(i,j,1) + 0.5*(mode_struct_sq(K)*N2(K) + & + mode_struct_sq(K+1)*N2(K+1)) * Hc(k) + enddo + + ! Note that remapping_core_h requires that the same units be used + ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. + do k = 1,kc + Hc_H(k) = GV%Z_to_H * Hc(k) + enddo + + ! for w (diag) interpolate onto all interfaces + call interpolate_column(kc, Hc_H(1:kc), mode_struct(1:kc+1), & + nz, h(i,j,:), modal_structure(:), .false.) + + ! for u (remap) onto all layers + call remapping_core_h(CS%remapping_CS, kc, Hc_H(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:), & + GV%H_subroundoff, GV%H_subroundoff) + + ! write the wave structure + do k=1,nz+1 + w_struct(i,j,k,1) = modal_structure(k) + enddo + + do k=1,nz + u_struct(i,j,k,1) = modal_structure_fder(k) + enddo + ! Find other eigen values if c1 is of significant magnitude, > cn_thresh nrootsfound = 0 ! number of extra roots found (not including 1st root) if ((nmodes > 1) .and. (kc >= nmodes+1) .and. (cn(i,j,1) > CS%c1_thresh)) then @@ -1128,16 +1264,105 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Use Newton's method to find the roots within the identified windows do m=1,nrootsfound ! loop over the root-containing widows (excluding 1st mode) lam_n = xbl(m) ! first guess is left edge of window + + ! init and first guess for mode structure + mode_struct(:) = 0. + mode_struct_fder(:) = 0. + mode_struct(2:kc) = 1. ! Uniform flow, first guess + modal_structure(:) = 0. + modal_structure_fder(:) = 0. + do itt=1,max_itt ! calculate the determinant of (A-lam_n*I) call tridiag_det(Igu, Igl, 2, kc, lam_n, det, ddet, row_scale=c2_scale) ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam + + call tdma6(kc-1, Igu(2:kc), Igl(2:kc), lam_n, mode_struct(2:kc)) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] + ! apply BC + mode_struct(1) = 0. + mode_struct(kc+1) = 0. + + ! renormalization of the integral of the profile + w2avg = 0.0 + do k=1,kc + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) + enddo + renorm = sqrt(htot(i)*a_int/w2avg) + do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo + if (abs(dlam) < tol_solve*lam_1) exit enddo ! itt-loop + ! calculate nth mode speed if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) + + ! sign is irrelevant, flip to positive if needed + if (mode_struct(2)<0.) then + mode_struct(2:kc) = -1. * mode_struct(2:kc) + endif + + ! derivative of vertical profile (i.e. dw/dz) is evaluated at the layer point + do k=1,kc + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / Hc(k) + enddo + + ! boundary condition for 1st derivative is no-gradient + do k=kc+1,nz + mode_struct_fder(k) = mode_struct_fder(kc) + enddo + + ! now save maximum value and bottom value + u_struct_bot(i,j,m) = mode_struct_fder(kc) + u_struct_max(i,j,m) = maxval(abs(mode_struct_fder(1:kc))) + + ! Calculate terms for vertically integrated energy equation + do k=1,kc + mode_struct_fder_sq(k) = mode_struct_fder(k)**2 + enddo + do K=1,kc+1 + mode_struct_sq(K) = mode_struct(K)**2 + enddo + + ! sum over layers for integral of quantities defined at layer points + do k=1,kc + int_U2(i,j,m) = int_U2(i,j,m) + mode_struct_fder_sq(k) * Hc(k) + enddo + + ! vertical integration with Trapezoidal rule for quantities on interfaces + do K=1,kc + int_w2(i,j,m) = int_w2(i,j,m) + 0.5*(mode_struct_sq(K)+mode_struct_sq(K+1)) * Hc(k) + int_N2w2(i,j,m) = int_N2w2(i,j,m) + 0.5*(mode_struct_sq(K)*N2(K) + & + mode_struct_sq(K+1)*N2(K+1)) * Hc(k) + enddo + + ! Note that remapping_core_h requires that the same units be used + ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. + do k = 1,kc + Hc_H(k) = GV%Z_to_H * Hc(k) + enddo + + ! for w (diag) interpolate onto all interfaces + call interpolate_column(kc, Hc_H(1:kc), mode_struct(1:kc+1), & + nz, h(i,j,:), modal_structure(:), .false.) + + ! for u (remap) onto all layers + call remapping_core_h(CS%remapping_CS, kc, Hc_H(1:kc), mode_struct_fder(1:kc), & + nz, h(i,j,:), modal_structure_fder(:), & + GV%H_subroundoff, GV%H_subroundoff) + + ! write the wave structure + ! note that m=1 solves for 2nd mode,... + do k=1,nz+1 + w_struct(i,j,k,m+1) = modal_structure(k) + enddo + + do k=1,nz + u_struct(i,j,k,m+1) = modal_structure_fder(k) + enddo + enddo ! n-loop endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh endif ! if more than 2 layers diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 6dda4c1b1c..d3f202339a 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -34,7 +34,7 @@ module MOM_internal_tides public get_lowmode_loss !> This control structure has parameters for the MOM_internal_tides module -type, public :: int_tide_CS ; private +type, public :: int_tide_CS logical :: do_int_tides !< If true, use the internal tide code. integer :: nFreq = 0 !< The number of internal tide frequency bands integer :: nMode = 1 !< The number of internal tide vertical modes @@ -95,6 +95,20 @@ module MOM_internal_tides !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:,:,:) :: w_struct !< Vertical structure of vertical velocity (normalized) + !! for each frequency and each mode [nondim] + real, allocatable, dimension(:,:,:,:) :: u_struct !< Vertical structure of horizontal velocity (normalized and + !! divided by layer thicknesses) for each frequency and each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: u_struct_max !< Maximum of u_struct, + !! for each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: u_struct_bot !< Bottom value of u_struct, + !! for each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: int_w2 !< Vertical integral of w_struct squared, + !! for each mode [Z ~> m] + real, allocatable, dimension(:,:,:) :: int_U2 !< Vertical integral of u_struct squared, + !! for each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times + !! vertical profile squared, for each mode [Z T-2 ~> m s-2] real :: q_itides !< fraction of local dissipation [nondim] real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. @@ -126,7 +140,6 @@ module MOM_internal_tides type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. - type(wave_structure_CS) :: wave_struct !< Wave structure control structure !>@{ Diag handles ! Diag handles relevant to all modes, frequencies, and angles @@ -148,6 +161,12 @@ module MOM_internal_tides integer, allocatable, dimension(:,:) :: & id_En_ang_mode, & id_itidal_loss_ang_mode + integer, allocatable, dimension(:) :: & + id_Ustruct_mode, & + id_Wstruct_mode, & + id_int_w2_mode, & + id_int_U2_mode, & + id_int_N2w2_mode !>@} end type int_tide_CS @@ -205,6 +224,10 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real :: I_D_here ! The inverse of the local depth [Z-1 ~> m-1] real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] real :: freq2 ! The frequency squared [T-2 ~> s-2] + real :: PE_term ! total potential energy of profile [R Z ~> kg m-2] + real :: KE_term ! total kinetic energy of profile [R Z ~> kg m-2] + real :: U_mag ! rescaled magnitude of horizontal profile [L Z T-1 ~> m2 s-1] + real :: W0 ! rescaled magnitude of vertical profile [Z T-1 ~> m s-1] real :: c_phase ! The phase speed [L T-1 ~> m s-1] real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim] @@ -222,6 +245,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle + nzm = GV%ke I_rho0 = 1.0 / GV%Rho0 cn_subRO = 1e-30*US%m_s_to_L_T en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T @@ -229,6 +253,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! initialize local arrays drag_scale(:,:) = 0. Ub(:,:,:,:) = 0. + Umax(:,:,:,:) = 0. ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** ! This is wrong, of course, but it works reasonably in some cases. @@ -417,15 +442,43 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! First, find velocity profiles if (CS%apply_wave_drag .or. CS%apply_Froude_drag) then do m=1,CS%NMode ; do fr=1,CS%Nfreq - ! Calculate modal structure for given mode and frequency - call wave_structure(h, tv, G, GV, US, cn(:,:,m), m, CS%frequency(fr), & - CS%wave_struct, tot_En_mode(:,:,fr,m), full_halos=.true.) - ! Pick out near-bottom and max horizontal baroclinic velocity values at each point + + ! compute near-bottom and max horizontal baroclinic velocity values at each point do j=jsd,jed ; do i=isd,ied id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - nzm = CS%wave_struct%num_intfaces(i,j) - Ub(i,j,fr,m) = CS%wave_struct%Uavg_profile(i,j,nzm) - Umax(i,j,fr,m) = maxval(CS%wave_struct%Uavg_profile(i,j,1:nzm)) + + ! Calculate wavenumber magnitude + freq2 = CS%frequency(fr)**2 + + f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & + G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 + Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + + + ! Back-calculate amplitude from energy equation + if ( (G%mask2dT(i,j) > 0.5) .and. (freq2*Kmag2 > 0.0)) then + ! Units here are [R Z ~> kg m-2] + KE_term = 0.25*GV%Rho0*( ((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m) + & + CS%int_w2(i,j,m) ) + PE_term = 0.25*GV%Rho0*( CS%int_N2w2(i,j,m) / freq2 ) + + if (KE_term + PE_term > 0.0) then + W0 = sqrt( tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) + else + !call MOM_error(WARNING, "MOM internal tides: KE + PE <= 0.0; setting to W0 to 0.0") + W0 = 0.0 + endif + + U_mag = W0 * sqrt((freq2 + f2) / (2.0*freq2*Kmag2)) + ! scaled maximum tidal velocity + Umax(i,j,fr,m) = abs(U_mag * CS%u_struct_max(i,j,m)) + ! scaled bottom tidal velocity + Ub(i,j,fr,m) = abs(U_mag * CS%u_struct_bot(i,j,m)) + else + Umax(i,j,fr,m) = 0. + Ub(i,j,fr,m) = 0. + endif + enddo ; enddo ! i-loop, j-loop enddo ; enddo ! fr-loop, m-loop endif ! apply_wave or _Froude_drag (Ub or Umax needed) @@ -454,7 +507,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Pick out maximum baroclinic velocity values; calculate Fr=max(u)/cg do m=1,CS%NMode ; do fr=1,CS%Nfreq freq2 = CS%frequency(fr)**2 - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging ! Calculate horizontal phase velocity magnitudes f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & @@ -463,7 +516,6 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & c_phase = 0.0 if (Kmag2 > 0.0) then c_phase = sqrt(freq2/Kmag2) - nzm = CS%wave_struct%num_intfaces(i,j) Fr2_max = (Umax(i,j,fr,m) / c_phase)**2 ! Dissipate energy if Fr>1; done here with an arbitrary time scale if (Fr2_max > 1.0) then @@ -635,6 +687,26 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & call post_data(CS%id_Ub_mode(fr,m), Ub(:,:,fr,m), CS%diag) endif ; enddo ; enddo + do m=1,CS%NMode ; if (CS%id_Ustruct_mode(m) > 0) then + call post_data(CS%id_Ustruct_mode(m), CS%u_struct(:,:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%NMode ; if (CS%id_Wstruct_mode(m) > 0) then + call post_data(CS%id_Wstruct_mode(m), CS%w_struct(:,:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%NMode ; if (CS%id_int_w2_mode(m) > 0) then + call post_data(CS%id_int_w2_mode(m), CS%int_w2(:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%NMode ; if (CS%id_int_U2_mode(m) > 0) then + call post_data(CS%id_int_U2_mode(m), CS%int_U2(:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%NMode ; if (CS%id_int_N2w2_mode(m) > 0) then + call post_data(CS%id_int_N2w2_mode(m), CS%int_N2w2(:,:,m), CS%diag) + endif ; enddo + ! Output 2-D horizontal phase velocity for each frequency and mode do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_cp_mode(fr,m) > 0) then call post_data(CS%id_cp_mode(fr,m), CS%cp(:,:,fr,m), CS%diag) @@ -2226,7 +2298,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! nominal ocean depth, or a negative value for no limit [nondim] real :: period_1 ! The period of the gravest modeled mode [T ~> s] integer :: num_angle, num_freq, num_mode, m, fr - integer :: isd, ied, jsd, jed, a, id_ang, i, j + integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang ! This include declares and sets the variable "version". # include "version_variable.h" @@ -2241,6 +2313,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=80) :: rough_var ! Input file variable names isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + nz = GV%ke use_int_tides = .false. call read_param(param_file, "INTERNAL_TIDES", use_int_tides) @@ -2407,6 +2480,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%tot_itidal_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_Froude_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_residual_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%u_struct_bot(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%u_struct_max(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_w2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_U2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_N2w2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%w_struct(isd:ied,jsd:jed,1:nz+1,num_mode), source=0.0) + allocate(CS%u_struct(isd:ied,jsd:jed,1:nz,num_mode), source=0.0) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -2593,6 +2673,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%id_allprocesses_loss_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_Ub_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Ustruct_mode(CS%nMode), source=-1) + allocate(CS%id_Wstruct_mode(CS%nMode), source=-1) + allocate(CS%id_int_w2_mode(CS%nMode), source=-1) + allocate(CS%id_int_U2_mode(CS%nMode), source=-1) + allocate(CS%id_int_N2w2_mode(CS%nMode), source=-1) allocate(CS%id_cp_mode(CS%nFreq,CS%nMode), source=-1) allocate(angles(CS%NAngle), source=0.0) @@ -2656,8 +2741,42 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo ; enddo - ! Initialize wave_structure (not sure if this should be here - BDM) - call wave_structure_init(Time, G, GV, param_file, diag, CS%wave_struct) + + do m=1,CS%nMode + + ! Register 3-D internal tide horizonal velocity profile for each mode + write(var_name, '("Itide_Ustruct","_mode",i1)') m + write(var_descript, '("horizonal velocity profile for mode ",i1)') m + CS%id_Ustruct_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesTl, Time, var_descript, 'm-1', conversion=US%m_to_L) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 3-D internal tide vertical velocity profile for each mode + write(var_name, '("Itide_Wstruct","_mode",i1)') m + write(var_descript, '("vertical velocity profile for mode ",i1)') m + CS%id_Wstruct_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesTi, Time, var_descript, '[]') + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_w2","_mode",i1)') m + write(var_descript, '("integral of w2 for mode ",i1)') m + CS%id_int_w2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm', conversion=US%Z_to_m) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_U2","_mode",i1)') m + write(var_descript, '("integral of U2 for mode ",i1)') m + CS%id_int_U2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm-1', conversion=US%m_to_L) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_N2w2","_mode",i1)') m + write(var_descript, '("integral of N2w2 for mode ",i1)') m + CS%id_int_N2w2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm s-2', conversion=US%Z_to_m*US%s_to_T**2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + enddo end subroutine internal_tides_init @@ -2670,6 +2789,12 @@ subroutine internal_tides_end(CS) if (allocated(CS%id_En_mode)) deallocate(CS%id_En_mode) if (allocated(CS%id_Ub_mode)) deallocate(CS%id_Ub_mode) if (allocated(CS%id_cp_mode)) deallocate(CS%id_cp_mode) + if (allocated(CS%id_Ustruct_mode)) deallocate(CS%id_Ustruct_mode) + if (allocated(CS%id_Wstruct_mode)) deallocate(CS%id_Wstruct_mode) + if (allocated(CS%id_int_w2_mode)) deallocate(CS%id_int_w2_mode) + if (allocated(CS%id_int_U2_mode)) deallocate(CS%id_int_U2_mode) + if (allocated(CS%id_int_N2w2_mode)) deallocate(CS%id_int_N2w2_mode) + end subroutine internal_tides_end end module MOM_internal_tides diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 0fe08a06b2..b0d04e434c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -396,7 +396,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%uniform_test_cg > 0.0) then do m=1,CS%nMode ; cn_IGW(:,:,m) = CS%uniform_test_cg ; enddo else - call wave_speeds(h, tv, G, GV, US, CS%nMode, cn_IGW, CS%wave_speed, full_halos=.true.) + call wave_speeds(h, tv, G, GV, US, CS%nMode, cn_IGW, CS%wave_speed, CS%int_tide%w_struct, & + CS%int_tide%u_struct, CS%int_tide%u_struct_max, CS%int_tide%u_struct_bot, & + CS%int_tide_input%Nb, CS%int_tide%int_w2, CS%int_tide%int_U2, CS%int_tide%int_N2w2, & + full_halos=.true.) endif call propagate_int_tide(h, tv, cn_IGW, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & From e45b983eee130982a448cac211a5d0141f352046 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Mon, 24 Apr 2023 22:01:09 -0400 Subject: [PATCH 89/91] remove wave_structure broken code --- src/diagnostics/MOM_wave_structure.F90 | 793 ------------------ .../lateral/MOM_internal_tides.F90 | 1 - 2 files changed, 794 deletions(-) delete mode 100644 src/diagnostics/MOM_wave_structure.F90 diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 deleted file mode 100644 index 80d23eeb75..0000000000 --- a/src/diagnostics/MOM_wave_structure.F90 +++ /dev/null @@ -1,793 +0,0 @@ -!> Vertical structure functions for first baroclinic mode wave speed -module MOM_wave_structure - -! This file is part of MOM6. See LICENSE.md for the license. - -! By Benjamin Mater & Robert Hallberg, 2015 - -! The subroutine in this module calculates the vertical structure -! functions of the first baroclinic mode internal wave speed. -! Calculation of interface values is the same as done in -! MOM_wave_speed by Hallberg, 2008. - -use MOM_debugging, only : isnan => is_NaN -use MOM_checksums, only : chksum0, hchksum -use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type -use MOM_EOS, only : calculate_density_derivs -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : log_version, param_file_type, get_param -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use regrid_solvers, only : solve_diag_dominant_tridiag - -implicit none ; private - -#include - -public wave_structure, wave_structure_init - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -!> The control structure for the MOM_wave_structure module -type, public :: wave_structure_CS ; !private - logical :: initialized = .false. !< True if this control structure has been initialized. - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to - !! regulate the timing of diagnostic output. - real, allocatable, dimension(:,:,:) :: w_strct - !< Vertical structure of vertical velocity (normalized) [nondim]. - real, allocatable, dimension(:,:,:) :: u_strct - !< Vertical structure of horizontal velocity (normalized and - !! divided by layer thicknesses) [Z-1 ~> m-1]. - real, allocatable, dimension(:,:,:) :: W_profile - !< Vertical profile of w_hat(z), where - !! w(x,y,z,t) = w_hat(z)*exp(i(kx+ly-freq*t)) is the full time- - !! varying vertical velocity with w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. - real, allocatable, dimension(:,:,:) :: Uavg_profile - !< Vertical profile of the magnitude of horizontal velocity, - !! (u^2+v^2)^0.5, averaged over a period [L T-1 ~> m s-1]. - real, allocatable, dimension(:,:,:) :: z_depths - !< Depths of layer interfaces [Z ~> m]. - real, allocatable, dimension(:,:,:) :: N2 - !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. - integer, allocatable, dimension(:,:):: num_intfaces - !< Number of layer interfaces (including surface and bottom) [nondim]. - ! logical :: int_tide_source_test !< If true, apply an arbitrary generation site for internal tide testing - ! integer :: int_tide_source_i !< I Location of generation site - ! integer :: int_tide_source_j !< J Location of generation site - logical :: debug !< debugging prints - -end type wave_structure_CS - -contains - -!> This subroutine determines the internal wave velocity structure for any mode. -!! -!! This subroutine solves for the eigen vector [vertical structure, e(k)] associated with -!! the first baroclinic mode speed [i.e., smallest eigen value (lam = 1/c^2)] of the -!! system d2e/dz2 = -(N2/cn2)e, or (A-lam*I)e = 0, where A = -(1/N2)(d2/dz2), lam = 1/c^2, -!! and I is the identity matrix. 2nd order discretization in the vertical lets this system -!! be represented as -!! -!! -Igu(k)*e(k-1) + (Igu(k)+Igl(k)-lam)*e(k) - Igl(k)*e(k+1) = 0.0 -!! -!! with rigid lid boundary conditions e(1) = e(nz+1) = 0.0 giving -!! -!! (Igu(2)+Igl(2)-lam)*e(2) - Igl(2)*e(3) = 0.0 -!! -Igu(nz)*e(nz-1) + (Igu(nz)+Igl(nz)-lam)*e(nz) = 0.0 -!! -!! where, upon noting N2 = reduced gravity/layer thickness, we get -!! Igl(k) = 1.0/(gprime(k)*H(k)) ; Igu(k) = 1.0/(gprime(k)*H(k-1)) -!! -!! The eigen value for this system is approximated using "wave_speed." This subroutine uses -!! these eigen values (mode speeds) to estimate the corresponding eigen vectors (velocity -!! structure) using the "inverse iteration with shift" method. The algorithm is -!! -!! Pick a starting vector reasonably close to mode structure and with unit magnitude, b_guess -!! For n=1,2,3,... -!! Solve (A-lam*I)e = e_guess for e -!! Set e_guess=e/|e| and repeat, with each iteration refining the estimate of e -subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halos) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: cn !< The (non-rotational) mode internal - !! gravity wave speed [L T-1 ~> m s-1]. - integer, intent(in) :: ModeNum !< Mode number - real, intent(in) :: freq !< Intrinsic wave frequency [T-1 ~> s-1]. - type(wave_structure_CS), intent(inout) :: CS !< Wave structure control struct - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: En !< Internal wave energy density [R Z3 T-2 ~> J m-2] - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. - ! Local variables - real, dimension(SZK_(GV)+1) :: & - dRho_dT, & !< Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] - dRho_dS, & !< Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] - pres, & !< Interface pressure [R L2 T-2 ~> Pa] - T_int, & !< Temperature interpolated to interfaces [C ~> degC] - S_int, & !< Salinity interpolated to interfaces [S ~> ppt] - gprime !< The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. - real, dimension(SZK_(GV)) :: & - Igl, Igu !< The inverse of the reduced gravity across an interface times - !< the thickness of the layer below (Igl) or above (Igu) it [T2 L-2 ~> s2 m-2]. - real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & !< Layer thicknesses after very thin layers are combined [Z ~> m] - Tf, & !< Layer temperatures after very thin layers are combined [C ~> degC] - Sf, & !< Layer salinities after very thin layers are combined [S ~> ppt] - Rf !< Layer densities after very thin layers are combined [R ~> kg m-3] - real, dimension(SZK_(GV)) :: & - Hc, & !< A column of layer thicknesses after convective instabilities are removed [Z ~> m] - Tc, & !< A column of layer temperatures after convective instabilities are removed [C ~> degC] - Sc, & !< A column of layer salinities after convective instabilities are removed [S ~> ppt] - Rc !< A column of layer densities after convective instabilities are removed [R ~> kg m-3] - real, dimension(SZI_(G),SZJ_(G)) :: & - htot !< The vertical sum of the thicknesses [Z ~> m] - real :: lam !< inverse of wave speed squared [T2 L-2 ~> s2 m-2] - real :: min_h_frac !< fractional (per layer) minimum thickness [nondim] - real :: Z_to_pres !< A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] - real, dimension(SZI_(G)) :: & - hmin, & !< Thicknesses [Z ~> m] - H_here, & !< A thickness [Z ~> m] - HxT_here, & !< A layer integrated temperature [C Z ~> degC m] - HxS_here, & !< A layer integrated salinity [S Z ~> ppt m] - HxR_here !< A layer integrated density [R Z ~> kg m-2] - real :: I_Hnew !< The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum !< The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real, parameter :: tol1 = 0.0001, tol2 = 0.001 ! Nondimensional tolerances [nondim] - real :: g_Rho0 !< G_Earth/Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. - ! real :: rescale, I_rescale - integer :: kf(SZI_(G)) - integer, parameter :: max_itt = 1 !< number of times to iterate in solving for eigenvector - real :: cg_subRO !< A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] - real, parameter :: a_int = 0.5 !< value of normalized integral: \int(w_strct^2)dz = a_int [nondim] - real :: I_a_int !< inverse of a_int [nondim] - real :: f2 !< squared Coriolis frequency [T-2 ~> s-2] - real :: Kmag2 !< magnitude of horizontal wave number squared [L-2 ~> m-2] - real :: emag2 ! The sum of the squared magnitudes of the guesses [nondim] - real :: pi_htot ! The gravest vertical wavenumber in this column [Z-1 ~> m-1] - real :: renorm ! A renormalization factor [nondim] - logical :: use_EOS !< If true, density is calculated from T & S using an - !! equation of state. - - ! local representations of variables in CS; note, - ! not all rows will be filled if layers get merged! - real, dimension(SZK_(GV)+1) :: w_strct !< Vertical structure of vertical velocity (normalized) [nondim]. - real, dimension(SZK_(GV)+1) :: u_strct !< Vertical structure of horizontal velocity (normalized and - !! divided by layer thicknesses) [Z-1 ~> m-1]. - real, dimension(SZK_(GV)+1) :: W_profile !< Vertical profile of w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. - real, dimension(SZK_(GV)+1) :: Uavg_profile !< Vertical profile of the magnitude of - !! horizontal velocity [L T-1 ~> m s-1]. - real, dimension(SZK_(GV)+1) :: z_int !< Integrated depth [Z ~> m] - real, dimension(SZK_(GV)+1) :: N2 !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. - real, dimension(SZK_(GV)+1) :: w_strct2 !< squared values [nondim] - real, dimension(SZK_(GV)+1) :: u_strct2 !< squared values [Z-2 ~> m-2] - real, dimension(SZK_(GV)) :: dz !< thicknesses of merged layers (same as Hc I hope) [Z ~> m] - ! real, dimension(SZK_(GV)+1) :: dWdz_profile !< profile of dW/dz times total depth [Z T-1 ~> m s-1] - real :: w2avg !< average of squared vertical velocity structure function [Z ~> m] - real :: int_dwdz2 !< Vertical integral of the square of u_strct [Z-1 ~> m-1] - real :: int_w2 !< Vertical integral of the square of w_strct [Z ~> m] - real :: int_N2w2 !< Vertical integral of N2 [Z T-2 ~> m s-2] - real :: KE_term !< terms in vertically averaged energy equation [R Z ~> kg m-2] - real :: PE_term !< terms in vertically averaged energy equation [R Z ~> kg m-2] - real :: W0 !< A vertical velocity magnitude [Z T-1 ~> m s-1] - real :: U_mag !< A horizontal velocity magnitude times the depth of the - !! ocean [Z L T-1 ~> m2 s-1] - real, dimension(SZK_(GV)-1) :: lam_z !< product of eigen value and gprime(k); one value for each - !< interface (excluding surface and bottom) [Z-1 ~> m-1] - real, dimension(SZK_(GV)-1) :: a_diag !< upper diagonal of tridiagonal matrix; one value for each - !< interface (excluding surface and bottom) [Z-1 ~> m-1] - real, dimension(SZK_(GV)-1) :: c_diag !< lower diagonal of tridiagonal matrix; one value for each - !< interface (excluding surface and bottom) [Z-1 ~> m-1] - real, dimension(SZK_(GV)-1) :: b_dom !< Matrix center diagonal offset from a_diag + c_diag; one value - !< for each interface (excluding surface and bottom) [Z-1 ~> m-1] - real, dimension(SZK_(GV)-1) :: e_guess !< guess at eigen vector with unit amplitude (for TDMA) [nondim] - real, dimension(SZK_(GV)-1) :: e_itt !< improved guess at eigen vector (from TDMA) [nondim] - real :: Pi ! 3.1415926535... [nondim] - integer :: i, j, k, k2, kc, itt, is, ie, js, je, nz, nzm, row, ig, jg, ig_stop, jg_stop - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - I_a_int = 1/a_int - - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_structure: "// & - "Module must be initialized before it is used.") - - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif - - Pi = (4.0*atan(1.0)) - - g_Rho0 = GV%g_Earth / GV%Rho0 - - !if (CS%debug) call chksum0(g_Rho0, "g/rho0 in wave struct", & - ! scale=(US%L_to_m**2)*US%m_to_Z*(US%s_to_T**2)*US%kg_m3_to_R) - - if (CS%debug) call chksum0(freq, "freq in wave_struct", scale=US%s_to_T) - - cg_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. - use_EOS = associated(tv%eqn_of_state) - - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) - ! rescale = 1024.0**4 ; I_rescale = 1.0/rescale - - min_h_frac = tol1 / real(nz) - - do j=js,je - ! First merge very thin layers with the one above (or below if they are - ! at the top). This also transposes the row order so that columns can - ! be worked upon one at a time. - do i=is,ie ; htot(i,j) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i,j) = htot(i,j) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo - - do i=is,ie - hmin(i) = htot(i,j)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 - HxT_here(i) = 0.0 ; HxS_here(i) = 0.0 ; HxR_here(i) = 0.0 - enddo - if (use_EOS) then - do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then - Hf(kf(i),i) = H_here(i) - Tf(kf(i),i) = HxT_here(i) / H_here(i) - Sf(kf(i),i) = HxS_here(i) / H_here(i) - kf(i) = kf(i) + 1 - - ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxT_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) - else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxT_here(i) = HxT_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) - endif - enddo ; enddo - do i=is,ie ; if (H_here(i) > 0.0) then - Hf(kf(i),i) = H_here(i) - Tf(kf(i),i) = HxT_here(i) / H_here(i) - Sf(kf(i),i) = HxS_here(i) / H_here(i) - endif ; enddo - else - do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then - Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) - kf(i) = kf(i) + 1 - - ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) - else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) - endif - enddo ; enddo - do i=is,ie ; if (H_here(i) > 0.0) then - Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) - endif ; enddo - endif ! use_EOS? - - ! From this point, we can work on individual columns without causing memory - ! to have page faults. - do i=is,ie ; if (cn(i,j) > 0.0) then - !----for debugging, remove later---- - ig = i + G%idg_offset ; jg = j + G%jdg_offset - !if (ig == CS%int_tide_source_i .and. jg == CS%int_tide_source_j) then - !----------------------------------- - if (G%mask2dT(i,j) > 0.0) then - - gprime(:) = 0.0 ! init gprime - pres(:) = 0.0 ! init pres - lam = 1/(cn(i,j)**2) - - ! Calculate drxh_sum - if (use_EOS) then - pres(1) = 0.0 - do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_pres*Hf(k-1,i) - T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) - S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) - enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) - - ! Sum the reduced gravities to find out how small a density difference - ! is negligibly small. - drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,dRho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & - dRho_dS(k)*(Sf(k,i)-Sf(k-1,i))) - enddo - else - drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo - endif ! use_EOS? - - ! Find gprime across each internal interface, taking care of convective - ! instabilities by merging layers. - if (drxh_sum >= 0.0) then - ! Merge layers to eliminate convective instabilities or exceedingly - ! small reduced gravities. - if (use_EOS) then - kc = 1 - Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) - do k=2,kf(i) - if ((dRho_dT(k)*(Tf(k,i)-Tc(kc)) + dRho_dS(k)*(Sf(k,i)-Sc(kc))) * & - (Hc(kc) + Hf(k,i)) < 2.0 * tol2*drxh_sum) then - ! Merge this layer with the one above and backtrack. - I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) - Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew - Sc(kc) = (Hc(kc)*Sc(kc) + Hf(k,i)*Sf(k,i)) * I_Hnew - Hc(kc) = (Hc(kc) + Hf(k,i)) - ! Backtrack to remove any convective instabilities above... Note - ! that the tolerance is a factor of two larger, to avoid limit how - ! far back we go. - do k2=kc,2,-1 - if ((dRho_dT(k2)*(Tc(k2)-Tc(k2-1)) + dRho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & - (Hc(k2) + Hc(k2-1)) < tol2*drxh_sum) then - ! Merge the two bottommost layers. At this point kc = k2. - I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) - Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew - Sc(kc-1) = (Hc(kc)*Sc(kc) + Hc(kc-1)*Sc(kc-1)) * I_Hnew - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) - kc = kc - 1 - else ; exit ; endif - enddo - else - ! Add a new layer to the column. - kc = kc + 1 - drho_dS(kc) = drho_dS(k) ; drho_dT(kc) = drho_dT(k) - Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) - endif - enddo - ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (dRho_dT(k)*(Tc(k)-Tc(k-1)) + & - dRho_dS(k)*(Sc(k)-Sc(k-1))) - enddo - else ! .not.use_EOS - ! Do the same with density directly... - kc = 1 - Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) - do k=2,kf(i) - if ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol2*drxh_sum) then - ! Merge this layer with the one above and backtrack. - Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) - Hc(kc) = (Hc(kc) + Hf(k,i)) - ! Backtrack to remove any convective instabilities above... Note - ! that the tolerance is a factor of two larger, to avoid limit how - ! far back we go. - do k2=kc,2,-1 - if ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol2*drxh_sum) then - ! Merge the two bottommost layers. At this point kc = k2. - Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) - kc = kc - 1 - else ; exit ; endif - enddo - else - ! Add a new layer to the column. - kc = kc + 1 - Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) - endif - enddo - ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (Rc(k)-Rc(k-1)) - enddo - endif ! use_EOS? - - !-----------------NOW FIND WAVE STRUCTURE------------------------------------- - ! Construct and solve tridiagonal system for the interior interfaces - ! Note that kc = number of layers, - ! kc+1 = nzm = number of interfaces, - ! kc-1 = number of interior interfaces (excluding surface and bottom) - ! Also, note that "K" refers to an interface, while "k" refers to the layer below. - ! Need at least 3 layers (2 internal interfaces) to generate a matrix, also - ! need number of layers to be greater than the mode number - if (kc >= max(3, ModeNum + 1)) then - ! Set depth at surface - z_int(1) = 0.0 - ! Calculate Igu, Igl, depth, and N2 at each interior interface - ! [excludes surface (K=1) and bottom (K=kc+1)] - do K=2,kc - Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) - z_int(K) = z_int(K-1) + Hc(k-1) - N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) - enddo - ! Set stratification for surface and bottom (setting equal to nearest interface for now) - N2(1) = N2(2) ; N2(kc+1) = N2(kc) - ! Calcualte depth at bottom - z_int(kc+1) = z_int(kc)+Hc(kc) - ! check that thicknesses sum to total depth - if (abs(z_int(kc+1)-htot(i,j)) > 1.e-14*htot(i,j)) then - call MOM_error(FATAL, "wave_structure: mismatch in total depths") - endif - - ! Populate interior rows of tridiagonal matrix; must multiply through by - ! gprime to get tridiagonal matrix to the symmetrical form: - ! [-1/H(k-1)]e(k-1) + [1/H(k-1)+1/H(k)-lam_z]e(k) + [-1/H(k)]e(k+1) = 0, - ! where lam_z = lam*gprime is now a function of depth. - ! First, populate interior rows - - ! init the values in matrix: since number of layers is variable, values need to be reset - lam_z(:) = 0.0 - a_diag(:) = 0.0 - b_dom(:) = 0.0 - c_diag(:) = 0.0 - e_guess(:) = 0.0 - e_itt(:) = 0.0 - w_strct(:) = 0.0 - do K=3,kc-1 - row = K-1 ! indexing for TD matrix rows - lam_z(row) = lam*gprime(K) - a_diag(row) = gprime(K)*(-Igu(K)) - b_dom(row) = 2.0*gprime(K)*(Igu(K)+Igl(K)) - lam_z(row) - c_diag(row) = gprime(K)*(-Igl(K)) - enddo - if (CS%debug) then ; do row=2,kc-2 - if (isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif - if (isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif - if (isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif - enddo ; endif - ! Populate top row of tridiagonal matrix - K=2 ; row = K-1 ; - lam_z(row) = lam*gprime(K) - a_diag(row) = 0.0 - b_dom(row) = gprime(K)*(Igu(K)+2.0*Igl(K)) - lam_z(row) - c_diag(row) = gprime(K)*(-Igl(K)) - ! Populate bottom row of tridiagonal matrix - K=kc ; row = K-1 - lam_z(row) = lam*gprime(K) - a_diag(row) = gprime(K)*(-Igu(K)) - b_dom(row) = gprime(K)*(2.0*Igu(K) + Igl(K)) - lam_z(row) - c_diag(row) = 0.0 - - ! Guess a normalized vector shape to start with (excludes surface and bottom) - emag2 = 0.0 - pi_htot = Pi / htot(i,j) - do K=2,kc - e_guess(K-1) = sin(pi_htot * z_int(K)) - emag2 = emag2 + e_guess(K-1)**2 - enddo - renorm = 1.0 / sqrt(emag2) - do K=2,kc ; e_guess(K-1) = renorm*e_guess(K-1) ; enddo - - ! Perform inverse iteration with tri-diag solver - do itt=1,max_itt - ! this solver becomes unstable very quickly - ! b_diag(1:kc-1) = b_dom(1:kc-1) - (a_diag(1:kc-1) + c_diag(1:kc-1)) - !call tridiag_solver(a_diag(1:kc-1),b_diag(1:kc-1),c_diag(1:kc-1), & - ! -lam_z(1:kc-1),e_guess(1:kc-1),"TDMA_T",e_itt) - - call solve_diag_dominant_tridiag( c_diag, b_dom, a_diag, e_guess, e_itt, kc-1 ) - ! Renormalize the guesses of the structure.- - emag2 = 0.0 - do K=2,kc ; emag2 = emag2 + e_itt(K-1)**2 ; enddo - renorm = 1.0 / sqrt(emag2) - do K=2,kc ; e_guess(K-1) = renorm*e_itt(K-1) ; enddo - - ! A test should be added here to evaluate convergence. - enddo ! itt-loop - do K=2,kc ; w_strct(K) = e_guess(K-1) ; enddo - w_strct(1) = 0.0 ! rigid lid at surface - w_strct(kc+1) = 0.0 ! zero-flux at bottom - - ! Check to see if solver worked - if (CS%debug) then - ig_stop = 0 ; jg_stop = 0 - if (isnan(sum(w_strct(1:kc+1)))) then - print *, "Wave_structure: w_strct has a NAN at ig=", ig, ", jg=", jg - if (iG%iec .or. jG%jec)then - print *, "This is occuring at a halo point." - endif - ig_stop = ig ; jg_stop = jg - endif - endif - - ! Normalize vertical structure function of w such that - ! \int(w_strct)^2dz = a_int (a_int could be any value, e.g., 0.5) - nzm = kc+1 ! number of layer interfaces after merging - !(including surface and bottom) - w2avg = 0.0 - do k=1,nzm-1 - dz(k) = Hc(k) - w2avg = w2avg + 0.5*(w_strct(K)**2+w_strct(K+1)**2)*dz(k) - enddo - ! correct renormalization: - renorm = sqrt(htot(i,j)*a_int/w2avg) - do K=1,kc+1 ; w_strct(K) = renorm * w_strct(K) ; enddo - - ! Calculate vertical structure function of u (i.e. dw/dz) - do K=2,nzm-1 - u_strct(K) = 0.5*((w_strct(K-1) - w_strct(K) )/dz(k-1) + & - (w_strct(K) - w_strct(K+1))/dz(k)) - enddo - u_strct(1) = (w_strct(1) - w_strct(2) )/dz(1) - u_strct(nzm) = (w_strct(nzm-1)- w_strct(nzm))/dz(nzm-1) - - ! Calculate wavenumber magnitude - f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & - G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 - Kmag2 = (freq**2 - f2) / (cn(i,j)**2 + cg_subRO**2) - - ! Calculate terms in vertically integrated energy equation - int_dwdz2 = 0.0 ; int_w2 = 0.0 ; int_N2w2 = 0.0 - do K=1,nzm - u_strct2(K) = u_strct(K)**2 - w_strct2(K) = w_strct(K)**2 - enddo - ! vertical integration with Trapezoidal rule - do k=1,nzm-1 - int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * dz(k) - int_w2 = int_w2 + 0.5*(w_strct2(K)+w_strct2(K+1)) * dz(k) - int_N2w2 = int_N2w2 + 0.5*(w_strct2(K)*N2(K)+w_strct2(K+1)*N2(K+1)) * dz(k) - enddo - - ! Back-calculate amplitude from energy equation - if (present(En) .and. (freq**2*Kmag2 > 0.0)) then - ! Units here are [R Z ~> kg m-2] - KE_term = 0.25*GV%Rho0*( ((freq**2 + f2) / (freq**2*Kmag2))*US%L_to_Z**2*int_dwdz2 + int_w2 ) - PE_term = 0.25*GV%Rho0*( int_N2w2 / freq**2 ) - if (En(i,j) >= 0.0) then - W0 = sqrt( En(i,j) / (KE_term + PE_term) ) - else - call MOM_error(WARNING, "wave_structure: En < 0.0; setting to W0 to 0.0") - print *, "En(i,j)=", En(i,j), " at ig=", ig, ", jg=", jg - W0 = 0.0 - endif - ! Calculate actual vertical velocity profile and derivative - U_mag = W0 * sqrt((freq**2 + f2) / (2.0*freq**2*Kmag2)) - do K=1,nzm - W_profile(K) = W0*w_strct(K) - ! dWdz_profile(K) = W0*u_strct(K) - ! Calculate average magnitude of actual horizontal velocity over a period - Uavg_profile(K) = abs(U_mag * u_strct(K)) - enddo - else - do K=1,nzm - W_profile(K) = 0.0 - ! dWdz_profile(K) = 0.0 - Uavg_profile(K) = 0.0 - enddo - endif - - ! Store values in control structure - do K=1,nzm - CS%w_strct(i,j,K) = w_strct(K) - CS%u_strct(i,j,K) = u_strct(K) - CS%W_profile(i,j,K) = W_profile(K) - CS%Uavg_profile(i,j,K) = Uavg_profile(K) - CS%z_depths(i,j,K) = z_int(K) - CS%N2(i,j,K) = N2(K) - enddo - CS%num_intfaces(i,j) = nzm - else - ! If not enough layers, default to zero - nzm = kc+1 - do K=1,nzm - CS%w_strct(i,j,K) = 0.0 - CS%u_strct(i,j,K) = 0.0 - CS%W_profile(i,j,K) = 0.0 - CS%Uavg_profile(i,j,K) = 0.0 - CS%z_depths(i,j,K) = 0.0 ! could use actual values - CS%N2(i,j,K) = 0.0 ! could use with actual values - enddo - CS%num_intfaces(i,j) = nzm - endif ! kc >= 3 and kc > ModeNum + 1? - endif ! drxh_sum >= 0? - !else ! if at test point - delete later - ! return ! if at test point - delete later - !endif ! if at test point - delete later - endif ! mask2dT > 0.0? - else - ! if cn=0.0, default to zero - nzm = nz+1 ! could use actual values - do K=1,nzm - CS%w_strct(i,j,K) = 0.0 - CS%u_strct(i,j,K) = 0.0 - CS%W_profile(i,j,K) = 0.0 - CS%Uavg_profile(i,j,K) = 0.0 - CS%z_depths(i,j,K) = 0.0 ! could use actual values - CS%N2(i,j,K) = 0.0 ! could use with actual values - enddo - CS%num_intfaces(i,j) = nzm - endif ; enddo ! if cn>0.0? ; i-loop - enddo ! j-loop - - if (CS%debug) call hchksum(CS%N2, 'N2 in wave_struct', G%HI, scale=US%s_to_T**2) - if (CS%debug) call hchksum(cn, 'cn in wave_struct', G%HI, scale=US%L_T_to_m_s) - if (CS%debug) call hchksum(CS%W_profile, 'Wprofile in wave_struct', G%HI, scale=US%Z_to_L*US%L_T_to_m_s) - if (CS%debug) call hchksum(CS%Uavg_profile, 'Uavg_profile in wave_struct', G%HI, scale=US%L_T_to_m_s) - -end subroutine wave_structure - -! The subroutine tridiag_solver is never used and could perhaps be deleted. - -!> Solves a tri-diagonal system Ax=y using either the standard -!! Thomas algorithm (TDMA_T) or its more stable variant that invokes the -!! "Hallberg substitution" (TDMA_H). -subroutine tridiag_solver(a, b, c, h, y, method, x) - real, dimension(:), intent(in) :: a !< lower diagonal with first entry equal to zero. - real, dimension(:), intent(in) :: b !< middle diagonal. - real, dimension(:), intent(in) :: c !< upper diagonal with last entry equal to zero. - real, dimension(:), intent(in) :: h !< vector of values that have already been added to b; used - !! for systems of the form (e.g. average layer thickness in vertical diffusion case): - !! [ -alpha(k-1/2) ] * e(k-1) + - !! [ alpha(k-1/2) + alpha(k+1/2) + h(k) ] * e(k) + - !! [ -alpha(k+1/2) ] * e(k+1) = y(k) - !! where a(k)=[-alpha(k-1/2)], b(k)=[alpha(k-1/2)+alpha(k+1/2) + h(k)], - !! and c(k)=[-alpha(k+1/2)]. Only used with TDMA_H method. - real, dimension(:), intent(in) :: y !< vector of known values on right hand side. - character(len=*), intent(in) :: method !< A string describing the algorithm to use - real, dimension(:), intent(out) :: x !< vector of unknown values to solve for. - ! Local variables - integer :: nrow ! number of rows in A matrix -! real, allocatable, dimension(:,:) :: A_check ! for solution checking -! real, allocatable, dimension(:) :: y_check ! for solution checking - real, allocatable, dimension(:) :: c_prime, y_prime, q, alpha - ! intermediate values for solvers - real :: Q_prime, beta ! intermediate values for solver - integer :: k ! row (e.g. interface) index - - nrow = size(y) - allocate(c_prime(nrow)) - allocate(y_prime(nrow)) - allocate(q(nrow)) - allocate(alpha(nrow)) -! allocate(A_check(nrow,nrow)) -! allocate(y_check(nrow)) - - if (method == 'TDMA_T') then - ! Standard Thomas algoritim (4th variant). - ! Note: Requires A to be non-singular for accuracy/stability - c_prime(:) = 0.0 ; y_prime(:) = 0.0 - c_prime(1) = c(1)/b(1) ; y_prime(1) = y(1)/b(1) - - ! Forward sweep - do k=2,nrow-1 - c_prime(k) = c(k)/(b(k)-a(k)*c_prime(k-1)) - enddo - !print *, 'c_prime=', c_prime(1:nrow) - do k=2,nrow - y_prime(k) = (y(k)-a(k)*y_prime(k-1))/(b(k)-a(k)*c_prime(k-1)) - enddo - !print *, 'y_prime=', y_prime(1:nrow) - x(nrow) = y_prime(nrow) - - ! Backward sweep - do k=nrow-1,1,-1 - x(k) = y_prime(k)-c_prime(k)*x(k+1) - enddo - !print *, 'x=',x(1:nrow) - - ! Check results - delete later - !do j=1,nrow ; do i=1,nrow - ! if (i==j)then ; A_check(i,j) = b(i) - ! elseif (i==j+1)then ; A_check(i,j) = a(i) - ! elseif (i==j-1)then ; A_check(i,j) = c(i) - ! endif - !enddo ; enddo - !print *, 'A(2,1),A(2,2),A(1,2)=', A_check(2,1), A_check(2,2), A_check(1,2) - !y_check = matmul(A_check,x) - !if (all(y_check /= y))then - ! print *, "tridiag_solver: Uh oh, something's not right!" - ! print *, "y=", y - ! print *, "y_check=", y_check - !endif - - elseif (method == 'TDMA_H') then - ! Thomas algoritim (4th variant) w/ Hallberg substitution. - ! For a layered system where k is at interfaces, alpha{k+1/2} refers to - ! some property (e.g. inverse thickness for mode-structure problem) of the - ! layer below and alpha{k-1/2} refers to the layer above. - ! Here, alpha(k)=alpha{k+1/2} and alpha(k-1)=alpha{k-1/2}. - ! Strictly speaking, this formulation requires A to be a non-singular, - ! symmetric, diagonally dominant matrix, with h>0. - ! Need to add a check for these conditions. - do k=1,nrow-1 - if (abs(a(k+1)-c(k)) > 1.e-10*(abs(a(k+1))+abs(c(k)))) then - call MOM_error(FATAL, "tridiag_solver: matrix not symmetric; need symmetry when invoking TDMA_H") - endif - enddo - alpha = -c - ! Alpha of the bottom-most layer is not necessarily zero. Therefore, - ! back out the value from the provided b(nrow and h(nrow) values - alpha(nrow) = b(nrow)-h(nrow)-alpha(nrow-1) - ! Prime other variables - beta = 1/b(1) - y_prime(:) = 0.0 ; q(:) = 0.0 - y_prime(1) = beta*y(1) ; q(1) = beta*alpha(1) - Q_prime = 1-q(1) - - ! Forward sweep - do k=2,nrow-1 - beta = 1/(h(k)+alpha(k-1)*Q_prime+alpha(k)) - if (isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif - q(k) = beta*alpha(k) - y_prime(k) = beta*(y(k)+alpha(k-1)*y_prime(k-1)) - Q_prime = beta*(h(k)+alpha(k-1)*Q_prime) - enddo - if ((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then - call MOM_error(FATAL, "Tridiag_solver: this system is not stable.") ! ; overriding beta(nrow) - ! This has hard-coded dimensions: beta = 1/(1e-15) ! place holder for unstable systems - delete later - else - beta = 1/(h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) - endif - y_prime(nrow) = beta*(y(nrow)+alpha(nrow-1)*y_prime(nrow-1)) - x(nrow) = y_prime(nrow) - ! Backward sweep - do k=nrow-1,1,-1 - x(k) = y_prime(k)+q(k)*x(k+1) - enddo - !print *, 'yprime=',y_prime(1:nrow) - !print *, 'x=',x(1:nrow) - endif - - deallocate(c_prime,y_prime,q,alpha) -! deallocate(A_check,y_check) - -end subroutine tridiag_solver - -!> Allocate memory associated with the wave structure module and read parameters. -subroutine wave_structure_init(Time, G, GV, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters. - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate - !! diagnostic output. - type(wave_structure_CS), intent(inout) :: CS !< Wave structure control struct - - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "MOM_wave_structure" ! This module's name. - integer :: isd, ied, jsd, jed, nz - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke - - CS%initialized = .true. - - ! call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_TEST", CS%int_tide_source_test, & - ! "If true, apply an arbitrary generation site for internal tide testing", & - ! default=.false.) - ! if (CS%int_tide_source_test) then - ! call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_I", CS%int_tide_source_i, & - ! "I Location of generation site for internal tide", default=0) - ! call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_J", CS%int_tide_source_j, & - ! "J Location of generation site for internal tide", default=0) - ! endif - call get_param(param_file, mdl, "DEBUG", CS%debug, & - "debugging prints", default=.false.) - - CS%diag => diag - - ! Allocate memory for variable in control structure; note, - ! not all rows will be filled if layers get merged! - allocate(CS%w_strct(isd:ied,jsd:jed,nz+1)) - allocate(CS%u_strct(isd:ied,jsd:jed,nz+1)) - allocate(CS%W_profile(isd:ied,jsd:jed,nz+1)) - allocate(CS%Uavg_profile(isd:ied,jsd:jed,nz+1)) - allocate(CS%z_depths(isd:ied,jsd:jed,nz+1)) - allocate(CS%N2(isd:ied,jsd:jed,nz+1)) - allocate(CS%num_intfaces(isd:ied,jsd:jed)) - - ! Write all relevant parameters to the model log. - call log_version(param_file, mdl, version, "") - -end subroutine wave_structure_init - -end module MOM_wave_structure diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index d3f202339a..ec07939ee4 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -23,7 +23,6 @@ module MOM_internal_tides use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_wave_structure, only: wave_structure_init, wave_structure, wave_structure_CS implicit none ; private From d0f7b297be08eb07fd2781fb03c858a39e648f9c Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 22 May 2023 09:59:36 -0400 Subject: [PATCH 90/91] Autoconf: Better Unicode Python support in makedep MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The `open()` commands in `makedep` for reading Fortran source now includes an `errors=` argument for catching bytes outside of the file character set. Unknown characters are replaced with the "unknown" character (usually �) rather than raising an error. This avoids problems with Unicode characters and older Pythons which do not support them, as well as characters from legacy encodings which can cause errors in Unicode. Substitution does not break any behavior, since Unicode is only permitted inside of comment blocks and strings. This fixes several errors which were silent in `.testing` but were observed by some users which using autoconf to build their own executables. --- ac/makedep | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ac/makedep b/ac/makedep index 439679f17d..225a241b93 100755 --- a/ac/makedep +++ b/ac/makedep @@ -4,9 +4,10 @@ from __future__ import print_function import argparse import glob +import io import os import re -import sys # used only to get path to current script +import sys # Pre-compile re searches @@ -255,7 +256,7 @@ def scan_fortran_file(src_file): """Scan the Fortran file "src_file" and return lists of module defined, module used, and files included.""" module_decl, used_modules, cpp_includes, f90_includes, programs = [], [], [], [], [] - with open(src_file, 'r') as file: + with io.open(src_file, 'r', errors='replace') as file: lines = file.readlines() for line in lines: match = re_module.match(line.lower()) From b075794d660a71693a67a0ee1de85fc1c24059ed Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 22 May 2023 14:54:43 -0400 Subject: [PATCH 91/91] Autoconf: Fix Python test and allow configuration The AC_PATH_PROGS macros used in Python testing were incorrectly using AC_MSG_ERROR in places where a missing value for PYTHON should be if the executable was not found. It also did not permit for a configurable PYTHON variable, since the autodetect was always run, even if PYTHON were set. This has been updated so that Python autodetection only runs if PYTHON is unset. It also correctly reports a failed configuration if PYTHON is not found. (It does not, however, test of PYTHON is actually a Python interpreter, but we can deal with that at a later date.) --- ac/configure.ac | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/ac/configure.ac b/ac/configure.ac index 1c10c14495..7ea1870816 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -236,15 +236,21 @@ AC_COMPILE_IFELSE( ] ) +# Python interpreter test -# Verify that Python is available -AC_PATH_PROGS([PYTHON], [python python3 python2], [ - AC_MSG_ERROR([Could not find python.]) -]) AC_ARG_VAR([PYTHON], [Python interpreter command]) +AS_VAR_SET_IF([PYTHON], [ + AC_PATH_PROGS([PYTHON], ["$PYTHON"], [none]) +], [ + AC_PATH_PROGS([PYTHON], [python python3 python2], [none]) +]) +AS_VAR_IF([PYTHON], [none], [ + AC_MSG_ERROR([Python interpreter not found.]) +]) + -# Verify that makedep is available +# Makedep test AC_PATH_PROG([MAKEDEP], [makedep], [${srcdir}/ac/makedep]) AC_SUBST([MAKEDEP])