From 30371003eb5b139b726c67f14e1f420c19978973 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 2 Jun 2022 15:14:59 -0400 Subject: [PATCH 01/81] 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 02/81] 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 03/81] 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 04/81] +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 05/81] 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 06/81] +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 07/81] 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 08/81] 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 09/81] 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 10/81] (*)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 11/81] +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 12/81] +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 13/81] 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 14/81] (*)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 15/81] +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 16/81] *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 17/81] +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 18/81] 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 19/81] *+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 20/81] +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 21/81] (*)+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 22/81] *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 23/81] *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 24/81] +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 25/81] +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 26/81] *+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 27/81] +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 28/81] 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 29/81] *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 30/81] +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 31/81] *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 32/81] +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 33/81] +*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 34/81] 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 35/81] +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 36/81] +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 37/81] +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 38/81] 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 39/81] 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 40/81] 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 82f750e58a08543c5f9ce8eb7bb587533ae60ba4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Apr 2023 08:51:41 -0400 Subject: [PATCH 41/81] +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 42/81] +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 43/81] +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 44/81] (*)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 45/81] (*)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 46/81] 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 47/81] 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 48/81] 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 49/81] 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 50/81] 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 51/81] +*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 52/81] +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 53/81] *+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 54/81] +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 55/81] +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 56/81] 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 57/81] 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 58/81] 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 59/81] 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]) From cb4574b3f540bd9e6bdfced6e04a56c8cbd6c3bb Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Wed, 29 Mar 2023 10:09:37 -0400 Subject: [PATCH 60/81] Fix PGI runtime issue with class(*) - Some tests such as global_ALE_z crash under PGI (ncrc4.pgi20 or ncrc5.pgi227) with FATAL from PE 27: unsupported attribute type: get_variable_attribute_0d: file:INPUT/tideamp.nc- variable:GRID_X_T attribute: axis - PGI in general has issues with class(*) construct and in this case cannot recognize the axis argument to be a string. - This mod helps PGI recognize that the argument is a string. --- config_src/infra/FMS2/MOM_io_infra.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 8802761774..2c3a5b8ad3 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -1524,9 +1524,9 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t if (variable_exists(fileobj, trim(dim_names(i)))) then cartesian = "" if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then - call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) + call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian(1:1)) elseif (variable_att_exists(fileobj, trim(dim_names(i)), "axis")) then - call get_variable_attribute(fileobj, trim(dim_names(i)), "axis", cartesian) + call get_variable_attribute(fileobj, trim(dim_names(i)), "axis", cartesian(1:1)) endif cartesian = adjustl(cartesian) if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. From 273da2fb272e37860c9617be3857aa8236a34f66 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 9 Jun 2023 18:17:59 -0400 Subject: [PATCH 61/81] Use fileset rather than threading for decompositon MOM IO was using the `threading` flag rather than `fileset` to determine whether a file should be forced as single file rather than domain-decomposed. This patch applies the correct flag. --- src/framework/MOM_io.F90 | 8 +++++--- src/framework/MOM_io_file.F90 | 4 ++-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 6bde678eb4..bebce6f502 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -338,12 +338,14 @@ subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & if (one_file) then if (domain_set) then call IO_handle%open(filename, action=OVERWRITE_FILE, & - MOM_domain=domain, threading=thread) + MOM_domain=domain, threading=thread, fileset=SINGLE_FILE) else - call IO_handle%open(filename, action=OVERWRITE_FILE, threading=thread) + call IO_handle%open(filename, action=OVERWRITE_FILE, threading=thread, & + fileset=SINGLE_FILE) endif else - call IO_handle%open(filename, action=OVERWRITE_FILE, MOM_domain=Domain) + call IO_handle%open(filename, action=OVERWRITE_FILE, MOM_domain=Domain, & + threading=thread, fileset=thread) endif ! Define the coordinates. diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index 6909e597ba..6eaa10f622 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -929,8 +929,8 @@ subroutine open_file_infra(handle, filename, action, MOM_domain, threading, file ! 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) & + if (present(MOM_domain) .and. present(fileset)) then + if (fileset == SINGLE_FILE) & use_single_file_domain = .true. endif From 6038735c43a08a18f3000ddf61f27821251f07b1 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 31 May 2023 14:05:39 -0400 Subject: [PATCH 62/81] FMS2 interpolation ID replaced with derived type All instances of an FMS ID to the internal interpolation content is replaced with a derived type containing additional metadata recording the field's origin filename and fieldname. This additional information is required in order to replicate the axis data from the field, which is no longer provided by FMS2. The abstraction of this type also allows us to either extend it or redefine it in other frameworks as needed in the future. This primarily affects the usage of the following functions: - init_external_field - time_interp_external - horiz_interp_and_extrap_tracer The following solvers are updated: - MOM_open_boundary - MOM_ice_shelf - MOM_oda_driver - MOM_MEKE - MOM_ALE_sponge - MOM_diabatic_aux Of these, OBC was the most significant. The integer handle (fid) was previously used to determine if each segment field was constant or (if negative) read from a file. After being replaced by the derived type, a new flag was added to make this determination. All of the coupled drivers have been modified, since they support time interpolation of T and S fields. - FMS - MCT - NUOPC The NUOPC driver also includes modifications to its CFC11 and CFC12 fields. Changes to the MOM CFC modules replaces an `id == -1`-like test, which is not used by the derived type. This check has been removed, and we now solely rely on the `present(cfc_handle)` test. While this could change behavior, there does not seem to be any scenario where init_external_field would return -1 but would be passed to the function. (But I may eat these words.) --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 15 +++-- .../mct_cap/mom_surface_forcing_mct.F90 | 15 +++-- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 28 +++++---- config_src/infra/FMS1/MOM_interp_infra.F90 | 54 +++++++++++------- config_src/infra/FMS2/MOM_interp_infra.F90 | 57 +++++++++++-------- src/core/MOM_open_boundary.F90 | 31 +++++----- src/framework/MOM_horizontal_regridding.F90 | 11 ++-- src/framework/MOM_interpolate.F90 | 27 +++++---- src/ice_shelf/MOM_ice_shelf.F90 | 17 +++--- src/ocean_data_assim/MOM_oda_driver.F90 | 15 ++--- src/parameterizations/lateral/MOM_MEKE.F90 | 7 ++- .../vertical/MOM_ALE_sponge.F90 | 32 +++++------ .../vertical/MOM_diabatic_aux.F90 | 3 +- src/tracer/MOM_CFC_cap.F90 | 20 ++++--- 14 files changed, 187 insertions(+), 145 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 26ab6269ef..f70cd34012 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -27,6 +27,7 @@ module MOM_surface_forcing_gfdl use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, write_version_number, MOM_read_data use MOM_io, only : read_netCDF_data use MOM_io, only : stdout_if_root @@ -153,8 +154,10 @@ module MOM_surface_forcing_gfdl !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring [nondim] - integer :: id_srestore = -1 !< An id number for time_interp_external. - integer :: id_trestore = -1 !< An id number for time_interp_external. + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field type(forcing_diags), public :: handles !< Diagnostics handles @@ -345,7 +348,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Salinity restoring logic if (CS%restore_salt) then - call time_interp_external(CS%id_srestore, Time, data_restore, scale=US%ppt_to_S) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice @@ -403,7 +406,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! SST restoring logic if (CS%restore_temp) then - call time_interp_external(CS%id_trestore, Time, data_restore, scale=US%degC_to_C) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) if ( CS%trestore_SPEAR_ECDA ) then do j=js,je ; do i=is,ie if (abs(data_restore(i,j)+1.8*US%degC_to_C) < 0.0001*US%degC_to_C) then @@ -1610,7 +1613,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if (CS%restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, MOM_domain=G%Domain) + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, MOM_domain=G%Domain) call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' @@ -1620,7 +1623,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if (CS%restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, MOM_domain=G%Domain) + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, MOM_domain=G%Domain) call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index 0364d46ddc..9b858af94e 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -25,6 +25,7 @@ module MOM_surface_forcing_mct use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, write_version_number, MOM_read_data use MOM_io, only : stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS @@ -134,8 +135,10 @@ module MOM_surface_forcing_mct !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' real, pointer, dimension(:,:) :: trestore_mask => NULL() !< mask for SST restoring - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field type(forcing_diags), public :: handles !< diagnostics handles type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer @@ -348,7 +351,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Salinity restoring logic if (restore_salinity) then - call time_interp_external(CS%id_srestore, Time, data_restore, scale=US%ppt_to_S) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice @@ -405,7 +408,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! SST restoring logic if (restore_sst) then - call time_interp_external(CS%id_trestore, Time, data_restore, scale=US%degC_to_C) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) do j=js,je ; do i=is,ie delta_sst = data_restore(i,j) - sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) @@ -1292,7 +1295,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (present(restore_salt)) then ; if (restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' @@ -1302,7 +1305,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (present(restore_temp)) then ; if (restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 2c8e3db8bd..b8162b4b59 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -26,6 +26,7 @@ module MOM_surface_forcing_nuopc use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_CFC_cap, only : CFC_cap_fluxes use MOM_io, only : slasher, write_version_number, MOM_read_data use MOM_io, only : stdout @@ -146,10 +147,14 @@ module MOM_surface_forcing_nuopc character(len=30) :: cfc11_var_name !< name of cfc11 in CFC_BC_file character(len=30) :: cfc12_var_name !< name of cfc11 in CFC_BC_file real, pointer, dimension(:,:) :: trestore_mask => NULL() !< mask for SST restoring - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. - integer :: id_cfc11_atm = -1 !< id number for time_interp_external. - integer :: id_cfc12_atm = -1 !< id number for time_interp_external. + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field + type(external_field) :: cfc11_atm_handle + !< Handle for time-interpolated CFC11 restoration field + type(external_field) :: cfc12_atm_handle + !< Handle for time-interpolated CFC12 restoration field ! Diagnostics handles type(forcing_diags), public :: handles @@ -377,7 +382,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Salinity restoring logic if (restore_salinity) then - call time_interp_external(CS%id_srestore, Time, data_restore, scale=US%ppt_to_S) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice @@ -434,7 +439,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! SST restoring logic if (restore_sst) then - call time_interp_external(CS%id_trestore, Time, data_restore, scale=US%degC_to_C) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) do j=js,je ; do i=is,ie delta_sst = data_restore(i,j) - sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) @@ -596,7 +601,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! CFCs if (CS%use_CFC) then - call CFC_cap_fluxes(fluxes, sfc_state, G, US, CS%Rho0, Time, CS%id_cfc11_atm, CS%id_cfc11_atm) + call CFC_cap_fluxes(fluxes, sfc_state, G, US, CS%Rho0, Time, & + CS%cfc11_atm_handle, CS%cfc11_atm_handle) endif if (associated(IOB%salt_flux)) then @@ -1394,7 +1400,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (present(restore_salt)) then ; if (restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' @@ -1404,7 +1410,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (present(restore_temp)) then ; if (restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' @@ -1430,8 +1436,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "The name of the variable representing CFC-12 in "//& "CFC_BC_FILE.", default="CFC_12", do_not_log=.true.) - CS%id_cfc11_atm = init_external_field(CS%CFC_BC_file, CS%cfc11_var_name, domain=G%Domain%mpp_domain) - CS%id_cfc12_atm = init_external_field(CS%CFC_BC_file, CS%cfc12_var_name, domain=G%Domain%mpp_domain) + CS%cfc11_atm_handle = init_external_field(CS%CFC_BC_file, CS%cfc11_var_name, domain=G%Domain%mpp_domain) + CS%cfc12_atm_handle = init_external_field(CS%CFC_BC_file, CS%cfc12_var_name, domain=G%Domain%mpp_domain) endif endif diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index 224e26a051..e14233a64b 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -18,6 +18,18 @@ module MOM_interp_infra public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights +public :: external_field + +!< Handle of an external field for interpolation +type :: external_field + private + integer :: id + !< FMS ID for the interpolated field + character(len=:), allocatable :: filename + !< Filename containing the field values + character(len=:), allocatable :: label + !< Field name in the file +end type external_field !> Read a field based on model time, and rotate to the model domain. interface time_interp_extern @@ -167,8 +179,8 @@ end function get_extern_field_missing !> Get information about the external fields. -subroutine get_external_field_info(field_id, size, axes, missing) - integer, intent(in) :: field_id !< The integer index of the external +subroutine get_external_field_info(field, size, axes, missing) + type(external_field), intent(in) :: field !< Handle for time interpolated external !! field returned from a previous !! call to init_external_field() integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data @@ -176,37 +188,35 @@ subroutine get_external_field_info(field_id, size, axes, missing) real, optional, intent(inout) :: missing !< Missing value for the input data if (present(size)) then - size(1:4) = get_extern_field_size(field_id) + size(1:4) = get_extern_field_size(field%id) endif if (present(axes)) then - axes(1:4) = get_extern_field_axes(field_id) + axes(1:4) = get_extern_field_axes(field%id) endif if (present(missing)) then - missing = get_extern_field_missing(field_id) + missing = get_extern_field_missing(field%id) endif end subroutine get_external_field_info !> Read a scalar field based on model time. -subroutine time_interp_extern_0d(field_id, time, data_in, verbose) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_0d(field, time, data_in, verbose) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, intent(inout) :: data_in !< The interpolated value logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging - call time_interp_external(field_id, time, data_in, verbose=verbose) + call time_interp_external(field%id, time, data_in, verbose=verbose) end subroutine time_interp_extern_0d !> Read a 2d field from an external based on model time, potentially including horizontal !! interpolation and rotation of the data -subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_2d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -216,15 +226,14 @@ subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_2d !> Read a 3d field based on model time, and rotate to the model grid -subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_3d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -234,14 +243,15 @@ subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_3d !> initialize an external field -integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & - threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency ) +function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency) & + result(field) character(len=*), intent(in) :: file !< The name of the file to read character(len=*), intent(in) :: fieldname !< The name of the field in the file @@ -261,17 +271,17 @@ integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, !! is in use, and (2) the modulo time period of the !! data is an integer number of years, then map !! a model date of Feb 29. onto a common year on Feb. 28. + type(external_field) :: field !< Handle to external field if (present(MOM_Domain)) then - init_extern_field = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & + field%id = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency) else - init_extern_field = init_external_field(file, fieldname, domain=domain, & + field%id = init_external_field(file, fieldname, domain=domain, & verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency) endif - end function init_extern_field end module MOM_interp_infra diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index c29459aad1..7964b3537f 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -18,6 +18,18 @@ module MOM_interp_infra public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights +public :: external_field + +!< Handle of an external field for interpolation +type :: external_field + private + integer :: id + !< FMS ID for the interpolated field + character(len=:), allocatable :: filename + !< Filename containing the field values + character(len=:), allocatable :: label + !< Field name in the file +end type external_field !> Read a field based on model time, and rotate to the model domain. interface time_interp_extern @@ -166,8 +178,8 @@ end function get_extern_field_missing !> Get information about the external fields. -subroutine get_external_field_info(field_id, size, axes, missing) - integer, intent(in) :: field_id !< The integer index of the external +subroutine get_external_field_info(field, size, axes, missing) + type(external_field), intent(in) :: field !< Handle for time interpolated external !! field returned from a previous !! call to init_external_field() integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data @@ -175,37 +187,35 @@ subroutine get_external_field_info(field_id, size, axes, missing) real, optional, intent(inout) :: missing !< Missing value for the input data if (present(size)) then - size(1:4) = get_extern_field_size(field_id) + size(1:4) = get_extern_field_size(field%id) endif if (present(axes)) then - axes(1:4) = get_extern_field_axes(field_id) + axes(1:4) = get_extern_field_axes(field%id) endif if (present(missing)) then - missing = get_extern_field_missing(field_id) + missing = get_extern_field_missing(field%id) endif end subroutine get_external_field_info !> Read a scalar field based on model time. -subroutine time_interp_extern_0d(field_id, time, data_in, verbose) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_0d(field, time, data_in, verbose) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, intent(inout) :: data_in !< The interpolated value logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging - call time_interp_external(field_id, time, data_in, verbose=verbose) + call time_interp_external(field%id, time, data_in, verbose=verbose) end subroutine time_interp_extern_0d !> Read a 2d field from an external based on model time, potentially including horizontal !! interpolation and rotation of the data -subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_2d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -215,15 +225,14 @@ subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_2d !> Read a 3d field based on model time, and rotate to the model grid -subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_3d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -233,14 +242,15 @@ subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_3d !> initialize an external field -integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & - threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency ) +function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency) & + result(field) character(len=*), intent(in) :: file !< The name of the file to read character(len=*), intent(in) :: fieldname !< The name of the field in the file @@ -260,19 +270,20 @@ integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, !! is in use, and (2) the modulo time period of the !! data is an integer number of years, then map !! a model date of Feb 29. onto a common year on Feb. 28. + type(external_field) :: field !< Handle to external field - + field%filename = file + field%label = fieldname if (present(MOM_Domain)) then - init_extern_field = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & + field%id = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency) else - init_extern_field = init_external_field(file, fieldname, domain=domain, & + field%id = init_external_field(file, fieldname, domain=domain, & verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency) endif - end function init_extern_field end module MOM_interp_infra diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9bd292e796..ba8b8ce818 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -24,6 +24,7 @@ module MOM_open_boundary use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping use MOM_regridding, only : regridding_CS @@ -81,8 +82,9 @@ module MOM_open_boundary !> Open boundary segment data from files (mostly). type, public :: OBC_segment_data_type - integer :: fid !< handle from FMS associated with segment data on disk - integer :: fid_dz !< handle from FMS associated with segment thicknesses on disk + type(external_field) :: handle !< handle from FMS associated with segment data on disk + type(external_field) :: dz_handle !< handle from FMS associated with segment thicknesses on disk + logical :: use_IO = .false. !< True if segment data is based on file input character(len=32) :: name !< a name identifier for the segment data character(len=8) :: genre !< an identifier for the segment data real :: scale !< A scaling factor for converting input data to @@ -96,7 +98,7 @@ module MOM_open_boundary real, allocatable :: buffer_dst(:,:,:) !< buffer src data remapped to the target vertical grid. !! The values for tracers should have the same units as the field !! they are being applied to? - real :: value !< constant value if fid is equal to -1 + real :: value !< constant value if not read from file real :: resrv_lfac_in = 1. !< reservoir inverse length scale factor for IN direction per field !< the general 1/Lscale_IN is multiplied by this factor for each tracer real :: resrv_lfac_out= 1. !< reservoir inverse length scale factor for OUT direction per field @@ -842,6 +844,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input ! value is rescaled there. segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) + segment%field(m)%use_IO = .true. if (segment%field(m)%name == 'TEMP') then segment%temp_segment_data_exists = .true. segment%t_values_needed = .false. @@ -957,7 +960,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) endif endif segment%field(m)%buffer_src(:,:,:) = 0.0 - segment%field(m)%fid = init_external_field(trim(filename), trim(fieldname), & + segment%field(m)%handle = init_external_field(trim(filename), trim(fieldname), & ignore_axis_atts=.true., threading=SINGLE_FILE) if (siz(3) > 1) then if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then @@ -988,7 +991,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) endif segment%field(m)%dz_src(:,:,:)=0.0 segment%field(m)%nk_src=siz(3) - segment%field(m)%fid_dz = init_external_field(trim(filename), trim(fieldname), & + segment%field(m)%dz_handle = init_external_field(trim(filename), trim(fieldname), & ignore_axis_atts=.true., threading=SINGLE_FILE) endif else @@ -996,12 +999,12 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) endif endif else - segment%field(m)%fid = -1 segment%field(m)%name = trim(fields(m)) ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input ! value is rescaled there. segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) segment%field(m)%value = segment%field(m)%scale * value + segment%field(m)%use_IO = .false. ! Check if this is a tidal field. If so, the number ! of expected constituents must be 1. @@ -3892,7 +3895,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) !a less frequent update as set by the parameter update_OBC_period_max in MOM.F90. !Cycle if it is not the time to update OBC segment data for this field. if (trim(segment%field(m)%genre) == 'obgc' .and. (.not. OBC%update_OBC_seg_data)) cycle - if (segment%field(m)%fid > 0) then + if (segment%field(m)%use_IO) then siz(1)=size(segment%field(m)%buffer_src,1) siz(2)=size(segment%field(m)%buffer_src,2) siz(3)=size(segment%field(m)%buffer_src,3) @@ -3972,7 +3975,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif ! This is where the data values are actually read in. - call time_interp_external(segment%field(m)%fid, Time, tmp_buffer_in, scale=segment%field(m)%scale) + call time_interp_external(segment%field(m)%handle, Time, tmp_buffer_in, scale=segment%field(m)%scale) ! NOTE: Rotation of face-points require that we skip the final value if (turns /= 0) then @@ -4045,7 +4048,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%field(m)%nk_src > 1 .and.& (index(segment%field(m)%name, 'phase') <= 0 .and. index(segment%field(m)%name, 'amp') <= 0)) then ! This is where the 2-d tidal data values are actually read in. - call time_interp_external(segment%field(m)%fid_dz, Time, tmp_buffer_in, scale=US%m_to_Z) + call time_interp_external(segment%field(m)%dz_handle, Time, tmp_buffer_in, scale=US%m_to_Z) if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. if (segment%is_E_or_W & @@ -4211,7 +4214,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) deallocate(tmp_buffer) if (turns /= 0) & deallocate(tmp_buffer_in) - else ! fid <= 0 (Uniform value) + else ! use_IO = .false. (Uniform value) if (.not. allocated(segment%field(m)%buffer_dst)) then if (segment%is_E_or_W) then if (segment%field(m)%name == 'V') then @@ -4257,7 +4260,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do m = 1,segment%num_fields !cycle if it is not the time to update OBGC tracers from source if (trim(segment%field(m)%genre) == 'obgc' .and. (.not. OBC%update_OBC_seg_data)) cycle - ! if (segment%field(m)%fid>0) then + ! if (segment%field(m)%use_IO) then ! calculate external BT velocity and transport if needed if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then if (trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) then @@ -4684,7 +4687,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & ! rescale the previously stored input values. Note that calls to register_segment_tracer ! can come before or after calls to initialize_segment_data. if (uppercase(segment%field(m)%name) == uppercase(segment%tr_Reg%Tr(ntseg)%name)) then - if (segment%field(m)%fid == -1) then + if (.not. segment%field(m)%use_IO) then rescale = scale if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) & rescale = scale / segment%field(m)%scale @@ -5948,8 +5951,8 @@ subroutine rotate_OBC_segment_data(segment_in, segment, turns) segment%num_fields = segment_in%num_fields do n = 1, num_fields - segment%field(n)%fid = segment_in%field(n)%fid - segment%field(n)%fid_dz = segment_in%field(n)%fid_dz + segment%field(n)%handle = segment_in%field(n)%handle + segment%field(n)%dz_handle = segment_in%field(n)%dz_handle if (modulo(turns, 2) /= 0) then select case (segment_in%field(n)%name) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 83e7718311..bedf710582 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -17,6 +17,7 @@ module MOM_horizontal_regridding use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_interp_infra, only : horiz_interp_type, horizontal_interp_init use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data +use MOM_interp_infra, only : external_field use MOM_time_manager, only : time_type use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data use MOM_io, only : read_attribute, read_variable @@ -598,12 +599,12 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr end subroutine horiz_interp_and_extrap_tracer_record !> Extrapolate and interpolate using a FMS time interpolation handle -subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, & +subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & z_in, z_edges_in, missing_value, scale, & homogenize, spongeOngrid, m_to_Z, & answers_2018, tr_iter_tol, answer_date) - integer, intent(in) :: fms_id !< A unique id used by the FMS time interpolator + type(external_field), intent(in) :: field !< Handle for the time interpolated field type(time_type), intent(in) :: Time !< A FMS time type type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z @@ -716,7 +717,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, call cpu_clock_begin(id_clock_read) - call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_val_in) + call get_external_field_info(field, size=fld_sz, axes=axes_data, missing=missing_val_in) missing_value = scale*missing_val_in verbosity = MOM_get_verbosity() @@ -790,7 +791,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, if (.not.is_ongrid) then if (is_root_pe()) & - call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) + call time_interp_external(field, Time, data_in, verbose=(verbosity>5), turns=turns) ! Loop through each data level and interpolate to model grid. ! After interpolating, fill in points which will be needed to define the layers. @@ -897,7 +898,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) + call time_interp_external(field, Time, data_in, verbose=(verbosity>5), turns=turns) do k=1,kd do j=js,je do i=is,ie diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 38a786e593..e131e8db9d 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -9,12 +9,14 @@ module MOM_interpolate use MOM_interp_infra, only : time_interp_external_init=>time_interp_extern_init use MOM_interp_infra, only : horiz_interp_type, get_external_field_info use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights +use MOM_interp_infra, only : external_field use MOM_time_manager, only : time_type implicit none ; private public :: time_interp_external, init_external_field, time_interp_external_init, get_external_field_info public :: horiz_interp_type, run_horiz_interp, build_horiz_interp_weights +public :: external_field !> Read a field based on model time, and rotate to the model domain. interface time_interp_external @@ -26,9 +28,8 @@ module MOM_interpolate contains !> Read a scalar field based on model time. -subroutine time_interp_external_0d(field_id, time, data_in, verbose, scale) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_external_0d(field, time, data_in, verbose, scale) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, intent(inout) :: data_in !< The interpolated value logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging @@ -48,7 +49,7 @@ subroutine time_interp_external_0d(field_id, time, data_in, verbose, scale) data_in = data_in * I_scale endif ; endif - call time_interp_extern(field_id, time, data_in, verbose=verbose) + call time_interp_extern(field, time, data_in, verbose=verbose) if (present(scale)) then ; if (scale /= 1.0) then ! Rescale data that has been newly set and restore the scaling of unset data. @@ -63,10 +64,9 @@ end subroutine time_interp_external_0d !> Read a 2d field from an external based on model time, potentially including horizontal !! interpolation and rotation of the data -subroutine time_interp_external_2d(field_id, time, data_in, interp, & +subroutine time_interp_external_2d(field, time, data_in, interp, & verbose, horz_interp, mask_out, turns, scale) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -105,11 +105,11 @@ subroutine time_interp_external_2d(field_id, time, data_in, interp, & qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) if (qturns == 0) then - call time_interp_extern(field_id, time, data_in, interp=interp, & + call time_interp_extern(field, time, data_in, interp=interp, & verbose=verbose, horz_interp=horz_interp) else call allocate_rotated_array(data_in, [1,1], -qturns, data_pre_rot) - call time_interp_extern(field_id, time, data_pre_rot, interp=interp, & + call time_interp_extern(field, time, data_pre_rot, interp=interp, & verbose=verbose, horz_interp=horz_interp) call rotate_array(data_pre_rot, turns, data_in) deallocate(data_pre_rot) @@ -136,10 +136,9 @@ end subroutine time_interp_external_2d !> Read a 3d field based on model time, and rotate to the model grid -subroutine time_interp_external_3d(field_id, time, data_in, interp, & +subroutine time_interp_external_3d(field, time, data_in, interp, & verbose, horz_interp, mask_out, turns, scale) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -178,11 +177,11 @@ subroutine time_interp_external_3d(field_id, time, data_in, interp, & qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) if (qturns == 0) then - call time_interp_extern(field_id, time, data_in, interp=interp, & + call time_interp_extern(field, time, data_in, interp=interp, & verbose=verbose, horz_interp=horz_interp) else call allocate_rotated_array(data_in, [1,1,1], -qturns, data_pre_rot) - call time_interp_extern(field_id, time, data_pre_rot, interp=interp, & + call time_interp_extern(field, time, data_pre_rot, interp=interp, & verbose=verbose, horz_interp=horz_interp) call rotate_array(data_pre_rot, turns, data_in) deallocate(data_pre_rot) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 113b6c045b..8e0e58c1b6 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -61,6 +61,7 @@ module MOM_ice_shelf use MOM_spatial_means, only : global_area_integral use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field implicit none ; private @@ -196,10 +197,10 @@ module MOM_ice_shelf id_shelf_sfc_mass_flux = -1 !>@} - integer :: id_read_mass !< An integer handle used in time interpolation of - !! the ice shelf mass read from a file - integer :: id_read_area !< An integer handle used in time interpolation of - !! the ice shelf mass read from a file + type(external_field) :: mass_handle + !< Handle for reading the time interpolated ice shelf mass from a file + type(external_field) :: area_handle + !< Handle for reading the time interpolated ice shelf area from a file type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. type(user_ice_shelf_CS), pointer :: user_CS => NULL() !< A pointer to the control structure for @@ -1118,7 +1119,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) do j=js,je ; do i=is,ie last_hmask(i,j) = ISS%hmask(i,j) ; last_area_shelf_h(i,j) = ISS%area_shelf_h(i,j) enddo ; enddo - call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) + call time_interp_external(CS%mass_handle, Time0, last_mass_shelf) do j=js,je ; do i=is,ie ! This should only be done if time_interp_extern did an update. last_mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(i,j) ! Rescale after time_interp @@ -1937,7 +1938,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) filename = trim(slasher(inputdir))//trim(shelf_file) call log_param(param_file, mdl, "INPUTDIR/SHELF_FILE", filename) - CS%id_read_mass = init_external_field(filename, shelf_mass_var, & + CS%mass_handle = init_external_field(filename, shelf_mass_var, & MOM_domain=CS%Grid_in%Domain, verbose=CS%debug) if (read_shelf_area) then @@ -1945,7 +1946,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) "The variable in SHELF_FILE with the shelf area.", & default="shelf_area") - CS%id_read_area = init_external_field(filename, shelf_area_var, & + CS%area_handle = init_external_field(filename, shelf_area_var, & MOM_domain=CS%Grid_in%Domain) endif @@ -2040,7 +2041,7 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) allocate(tmp2d(is:ie,js:je), source=0.0) endif - call time_interp_external(CS%id_read_mass, Time, tmp2d) + call time_interp_external(CS%mass_handle, Time, tmp2d) call rotate_array(tmp2d, CS%turns, ISS%mass_shelf) deallocate(tmp2d) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 8a1aab3328..53615b0063 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -17,6 +17,7 @@ module MOM_oda_driver_mod use MOM_io, only : SINGLE_FILE use MOM_interp_infra, only : init_extern_field, get_external_field_info use MOM_interp_infra, only : time_interp_extern +use MOM_interpolate, only : external_field use MOM_remapping, only : remappingSchemesDoc use MOM_time_manager, only : time_type, real_to_time, get_date use MOM_time_manager, only : operator(+), operator(>=), operator(/=) @@ -80,8 +81,8 @@ module MOM_oda_driver_mod !> A structure containing integer handles for bias adjustment of tracers type :: INC_CS integer :: fldno = 0 !< The number of tracers - integer :: T_id !< The integer handle for the temperature file - integer :: S_id !< The integer handle for the salinity file + type(external_field) :: T !< The handle for the temperature file + type(external_field) :: S !< The handle for the salinity file end type INC_CS !> Control structure that contains a transpose of the ocean state across ensemble members. @@ -391,11 +392,11 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) "tendency adjustments", default='temp_salt_adjustment.nc') inc_file = trim(inputdir) // trim(bias_correction_file) - CS%INC_CS%T_id = init_extern_field(inc_file, "temp_increment", & + CS%INC_CS%T = init_extern_field(inc_file, "temp_increment", & correct_leap_year_inconsistency=.true.,verbose=.true.,domain=G%Domain%mpp_domain) - CS%INC_CS%S_id = init_extern_field(inc_file, "salt_increment", & + CS%INC_CS%S = init_extern_field(inc_file, "salt_increment", & correct_leap_year_inconsistency=.true.,verbose=.true.,domain=G%Domain%mpp_domain) - call get_external_field_info(CS%INC_CS%T_id,size=fld_sz) + call get_external_field_info(CS%INC_CS%T, size=fld_sz) CS%INC_CS%fldno = 2 if (CS%nk /= fld_sz(3)) call MOM_error(FATAL,'Increment levels /= ODA levels') @@ -578,9 +579,9 @@ subroutine get_bias_correction_tracer(Time, US, CS) call cpu_clock_begin(id_clock_bias_adjustment) - call horiz_interp_and_extrap_tracer(CS%INC_CS%T_id, Time, CS%G, T_bias, & + call horiz_interp_and_extrap_tracer(CS%INC_CS%T, Time, CS%G, T_bias, & valid_flag, z_in, z_edges_in, missing_value, scale=US%degC_to_C*US%s_to_T, spongeOngrid=.true.) - call horiz_interp_and_extrap_tracer(CS%INC_CS%S_id, Time, CS%G, S_bias, & + call horiz_interp_and_extrap_tracer(CS%INC_CS%S, Time, CS%G, S_bias, & valid_flag, z_in, z_edges_in, missing_value, scale=US%ppt_to_S*US%s_to_T, spongeOngrid=.true.) ! This should be replaced to use mask_z instead of the following lines diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 2a5cef5974..6a439dfd22 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -21,6 +21,7 @@ module MOM_MEKE use MOM_interface_heights, only : find_eta use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : vardesc, var_desc, slasher use MOM_isopycnal_slopes, only : calc_isoneutral_slopes use MOM_restart, only : MOM_restart_CS, register_restart_field, query_initialized @@ -129,7 +130,7 @@ module MOM_MEKE integer :: id_Lrhines = -1, id_Leady = -1 integer :: id_MEKE_equilibrium = -1 !>@} - integer :: id_eke = -1 !< Handle for reading in EKE from a file + type(external_field) :: eke_handle !< Handle for reading in EKE from a file ! Infrastructure integer :: id_clock_pass !< Clock for group pass calls type(group_pass_type) :: pass_MEKE !< Group halo pass handle for MEKE%MEKE and maybe MEKE%Kh_diff @@ -627,7 +628,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif case(EKE_FILE) - call time_interp_external(CS%id_eke, Time, data_eke, scale=US%m_s_to_L_T**2) + call time_interp_external(CS%eke_handle, Time, data_eke, scale=US%m_s_to_L_T**2) do j=js,je ; do i=is,ie MEKE%MEKE(i,j) = data_eke(i,j) * G%mask2dT(i,j) enddo; enddo @@ -1153,7 +1154,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, inputdir = slasher(inputdir) eke_filename = trim(inputdir) // trim(eke_filename) - CS%id_eke = init_external_field(eke_filename, eke_varname, domain=G%Domain%mpp_domain) + CS%eke_handle = init_external_field(eke_filename, eke_varname, domain=G%Domain%mpp_domain) case("prog") CS%eke_src = EKE_PROG ! Read all relevant parameters and write them to the model log. diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 584ccccc93..2a30f68b42 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -22,6 +22,7 @@ module MOM_ALE_sponge use MOM_grid, only : ocean_grid_type use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer use MOM_interpolate, only : init_external_field, get_external_field_info, time_interp_external_init +use MOM_interpolate, only : external_field use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_spatial_means, only : global_i_mean use MOM_time_manager, only : time_type @@ -66,7 +67,7 @@ module MOM_ALE_sponge !> A structure for creating arrays of pointers to 3D arrays with extra gridding information type :: p3d - integer :: id !< id for FMS external time interpolator + !integer :: id !< id for FMS external time interpolator integer :: nz_data !< The number of vertical levels in the input field. integer :: num_tlevs !< The number of time records contained in the file real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data [various] @@ -75,7 +76,7 @@ module MOM_ALE_sponge !> A structure for creating arrays of pointers to 2D arrays with extra gridding information type :: p2d - integer :: id !< id for FMS external time interpolator + type(external_field) :: field !< Time interpolator field handle integer :: nz_data !< The number of vertical levels in the input field integer :: num_tlevs !< The number of time records contained in the file real :: scale = 1.0 !< A multiplicative factor by which to rescale input data [various] @@ -771,7 +772,6 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, !! if not given, use 'none' real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any !! contributions due to dimensional rescaling [various ~> 1]. - !! The default is 1. ! Local variables integer :: isd, ied, jsd, jed @@ -798,15 +798,15 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, ! get a unique time interp id for this field. If sponge data is on-grid, then setup ! to only read on the computational domain if (CS%spongeDataOngrid) then - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname, MOM_domain=G%Domain) + CS%Ref_val(CS%fldno)%field = init_external_field(filename, fieldname, MOM_domain=G%Domain) else - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) + CS%Ref_val(CS%fldno)%field = init_external_field(filename, fieldname) endif CS%Ref_val(CS%fldno)%name = sp_name CS%Ref_val(CS%fldno)%long_name = long_name CS%Ref_val(CS%fldno)%unit = unit fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val(CS%fldno)%id, size=fld_sz) + call get_external_field_info(CS%Ref_val(CS%fldno)%field, size=fld_sz) nz_data = fld_sz(3) CS%Ref_val(CS%fldno)%nz_data = nz_data !< individual sponge fields may reside on a different vertical grid CS%Ref_val(CS%fldno)%num_tlevs = fld_sz(4) @@ -899,23 +899,23 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename ! containing time-interpolated values from an external file corresponding ! to the current model date. if (CS%spongeDataOngrid) then - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) + CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) else - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) + CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u) endif fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val_u%id, size=fld_sz) + call get_external_field_info(CS%Ref_val_u%field, size=fld_sz) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) CS%Ref_val_u%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_u%scale = scale if (CS%spongeDataOngrid) then - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) + CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) else - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) + CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v) endif fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val_v%id, size=fld_sz) + call get_external_field_info(CS%Ref_val_v%field, size=fld_sz) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) CS%Ref_val_v%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_v%scale = scale @@ -989,7 +989,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%time_varying_sponges) then do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data - call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id, Time, G, sp_val, & + call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val(m)%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & answer_date=CS%hor_regrid_answer_date) @@ -1073,7 +1073,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%time_varying_sponges) then nz_data = CS%Ref_val_u%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, G, sp_val, & + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val_u%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & answer_date=CS%hor_regrid_answer_date) @@ -1121,7 +1121,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) deallocate(sp_val, mask_u, mask_z, hsrc) nz_data = CS%Ref_val_v%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, G, sp_val, & + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%field, Time, G, sp_val, & mask_z, z_in, z_edges_in, missing_value, & scale=CS%Ref_val_v%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& answer_date=CS%hor_regrid_answer_date) @@ -1341,7 +1341,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) ! We don't want to repeat FMS init in set_up_ALE_sponge_field_varying() ! (time_interp_external_init, init_external_field, etc), so we manually ! do a portion of this function below. - sponge%Ref_val(n)%id = sponge_in%Ref_val(n)%id + sponge%Ref_val(n)%field = sponge_in%Ref_val(n)%field sponge%Ref_val(n)%num_tlevs = sponge_in%Ref_val(n)%num_tlevs nz_data = sponge_in%Ref_val(n)%nz_data diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 5f7acd982b..3096fe72cd 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -16,6 +16,7 @@ module MOM_diabatic_aux use MOM_forcing_type, only : forcing, extractFluxes1d, forcing_SinglePointPrint use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher use MOM_opacity, only : set_opacity, opacity_CS, extract_optics_slice, extract_optics_fields use MOM_opacity, only : optics_type, optics_nbands, absorbRemainingSW, sumSWoverBands @@ -64,7 +65,7 @@ module MOM_diabatic_aux !! is added with a temperature of the local SST. logical :: var_pen_sw !< If true, use one of the CHL_A schemes to determine the !! e-folding depth of incoming shortwave radiation. - integer :: sbc_chl !< An integer handle used in time interpolation of + type(external_field) :: sbc_chl !< A handle used in time interpolation of !! chlorophyll read from a file. logical :: chl_from_file !< If true, chl_a is read from a file. diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 2a5e3f8854..ef8e712b7a 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -1,4 +1,4 @@ -!> Simulates CFCs using atmospheric pressure, wind speed and sea ice cover + !> Simulates CFCs using atmospheric pressure, wind speed and sea ice cover !! provided via cap (only NUOPC cap is implemented so far). module MOM_CFC_cap @@ -19,7 +19,8 @@ module MOM_CFC_cap use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_spatial_means, only : global_mass_int_EFP use MOM_time_manager, only : time_type -use time_interp_external_mod, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external +use MOM_interpolate, only : external_field use MOM_tracer_registry, only : register_tracer use MOM_tracer_types, only : tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut @@ -428,7 +429,8 @@ end subroutine CFC_cap_surface_state !> Orchestrates the calculation of the CFC fluxes [mol m-2 s-1], including getting the ATM !! concentration, and calculating the solubility, Schmidt number, and gas exchange. -subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id_cfc12_atm) +subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, & + cfc11_atm_handle, cfc12_atm_handle) type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type type(surface), intent(in ) :: sfc_state !< A structure containing fields @@ -439,8 +441,8 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id real, intent(in ) :: Rho0 !< The mean ocean density [R ~> kg m-3] type(time_type), intent(in ) :: Time !< The time of the fluxes, used for interpolating the !! CFC's concentration in the atmosphere. - integer, optional, intent(inout):: id_cfc11_atm !< id number for time_interp_external. - integer, optional, intent(inout):: id_cfc12_atm !< id number for time_interp_external. + type(external_field), optional, intent(inout) :: cfc11_atm_handle !< Handle for time-interpolated CFC11 + type(external_field), optional, intent(inout) :: cfc12_atm_handle !< Handle for time-interpolated CFC12 ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -463,8 +465,8 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ! CFC11 ATM concentration - if (present(id_cfc11_atm) .and. (id_cfc11_atm /= -1)) then - call time_interp_external(id_cfc11_atm, Time, cfc11_atm) + if (present(cfc11_atm_handle)) then + call time_interp_external(cfc11_atm_handle, Time, cfc11_atm) ! convert from ppt (pico mol/mol) to mol/mol cfc11_atm = cfc11_atm * 1.0e-12 else @@ -474,8 +476,8 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id endif ! CFC12 ATM concentration - if (present(id_cfc12_atm) .and. (id_cfc12_atm /= -1)) then - call time_interp_external(id_cfc12_atm, Time, cfc12_atm) + if (present(cfc12_atm_handle)) then + call time_interp_external(cfc12_atm_handle, Time, cfc12_atm) ! convert from ppt (pico mol/mol) to mol/mol cfc12_atm = cfc12_atm * 1.0e-12 else From 1c6dd7fef5a16585e467b59893d4ee9499150afb Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 6 Jun 2023 20:35:24 -0400 Subject: [PATCH 63/81] FMS2: Remove MPP-based axis data access With removal of axis-based operations in FMS2 I/O, this patch removes references to these calls and replaces them with MOM `axes_info` types. References to FMS1 read into an `axistype`, but the contents are transferred to an `axis_info`. FMS2 directly populates the `axis_info` content. The `get_external_field_info` calls are modified to return `axis_info` rather than `axistype`. The redundant `get_axis_data` function is also removed from `MOM_interp_infra`, since `get_axis_info` provides an equivalent operation. Generally speaking, this is not an improvement of the codebase. The FMS1 layer does a redundant copy of data from `axistype` to `axis_info`. The FMS2 layer is significantly worse, and re-opens the file to read the axis data for each field! But if the intention is to leverage the existing API, then I don't think we have any choice at the moment. Assuming this is a relatively infrequent operation, this should not cause any measureable issues, but it needs to be watched carefully. --- config_src/infra/FMS1/MOM_interp_infra.F90 | 44 +++++++++++++++------ config_src/infra/FMS2/MOM_interp_infra.F90 | 32 ++++++--------- src/framework/MOM_horizontal_regridding.F90 | 10 ++--- 3 files changed, 49 insertions(+), 37 deletions(-) diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index e14233a64b..70bc99827e 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -4,9 +4,11 @@ module MOM_interp_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_io, only : axis_info +use MOM_io, only : set_axis_info use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type -use mpp_io_mod, only : axistype, mpp_get_axis_data +use mpp_io_mod, only : axistype, mpp_get_axis_data, mpp_get_atts use time_interp_external_mod, only : time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init use time_interp_external_mod, only : get_external_field_size @@ -157,13 +159,33 @@ end function get_extern_field_size !> get axes of an external field from field index -function get_extern_field_axes(index) +function get_extern_field_axes(index) result(axes) - integer, intent(in) :: index !< field index - type(axistype), dimension(4) :: get_extern_field_axes !< field axes + integer, intent(in) :: index !< FMS interpolation field index + type(axis_info) :: axes(4) !< MOM IO field axes handle - get_extern_field_axes = get_external_field_axes(index) + type(axistype), dimension(4) :: fms_axes(4) + ! FMS axis handles + character(len=32) :: name + ! Axis name + real, allocatable :: points(:) + ! Axis line points + integer :: length + ! Axis line point length + integer :: i + ! Loop index + fms_axes = get_external_field_axes(index) + + do i = 1, 4 + call mpp_get_atts(fms_axes(i), name=name, len=length) + + allocate(points(length)) + call mpp_get_axis_data(fms_axes(i), points) + call set_axis_info(axes(i), name=name, ax_data=points) + + deallocate(points) + enddo end function get_extern_field_axes @@ -180,12 +202,12 @@ end function get_extern_field_missing !> Get information about the external fields. subroutine get_external_field_info(field, size, axes, missing) - type(external_field), intent(in) :: field !< Handle for time interpolated external - !! field returned from a previous - !! call to init_external_field() - integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data - type(axistype), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data - real, optional, intent(inout) :: missing !< Missing value for the input data + type(external_field), intent(in) :: field !< Handle for time interpolated external + !! field returned from a previous + !! call to init_external_field() + integer, optional, intent(inout) :: size(4) !< Dimension sizes for the input data + type(axis_info), optional, intent(inout) :: axes(4) !< Axis types for the input data + real, optional, intent(inout) :: missing !< Missing value for the input data if (present(size)) then size(1:4) = get_extern_field_size(field%id) diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index 7964b3537f..db471d0fc1 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -4,9 +4,10 @@ module MOM_interp_infra ! This file is part of MOM6. See LICENSE.md for the license. use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_io, only : axis_info +use MOM_io, only : get_var_axes_info use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type -use mpp_io_mod, only : axistype, mpp_get_axis_data use time_interp_external_mod, only : time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init use time_interp_external_mod, only : get_external_field_size @@ -16,7 +17,7 @@ module MOM_interp_infra public :: horiz_interp_type, horizontal_interp_init public :: time_interp_extern, init_extern_field, time_interp_extern_init -public :: get_external_field_info, axistype, get_axis_data +public :: get_external_field_info public :: run_horiz_interp, build_horiz_interp_weights public :: external_field @@ -135,15 +136,6 @@ subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, end subroutine build_horiz_interp_weights_2d_to_2d -!> Extracts and returns the axis data stored in an axistype. -subroutine get_axis_data( axis, dat ) - type(axistype), intent(in) :: axis !< An axis type - real, dimension(:), intent(out) :: dat !< The data in the axis variable - - call mpp_get_axis_data( axis, dat ) -end subroutine get_axis_data - - !> get size of an external field from field index function get_extern_field_size(index) @@ -156,13 +148,11 @@ end function get_extern_field_size !> get axes of an external field from field index -function get_extern_field_axes(index) - - integer, intent(in) :: index !< field index - type(axistype), dimension(4) :: get_extern_field_axes !< field axes - - get_extern_field_axes = get_external_field_axes(index) +function get_extern_field_axes(field) result(axes) + type(external_field), intent(in) :: field !< Field handle + type(axis_info), dimension(4) :: axes !< Field axes + call get_var_axes_info(field%filename, field%label, axes) end function get_extern_field_axes @@ -182,16 +172,16 @@ subroutine get_external_field_info(field, size, axes, missing) type(external_field), intent(in) :: field !< Handle for time interpolated external !! field returned from a previous !! call to init_external_field() - integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data - type(axistype), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data - real, optional, intent(inout) :: missing !< Missing value for the input data + integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data + type(axis_info), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data + real, optional, intent(inout) :: missing !< Missing value for the input data if (present(size)) then size(1:4) = get_extern_field_size(field%id) endif if (present(axes)) then - axes(1:4) = get_extern_field_axes(field%id) + axes(1:4) = get_extern_field_axes(field) endif if (present(missing)) then diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index bedf710582..883653d715 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -16,7 +16,7 @@ module MOM_horizontal_regridding use MOM_interpolate, only : time_interp_external use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_interp_infra, only : horiz_interp_type, horizontal_interp_init -use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data +use MOM_interp_infra, only : get_external_field_info use MOM_interp_infra, only : external_field use MOM_time_manager, only : time_type use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data @@ -668,7 +668,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] logical :: add_np type(horiz_interp_type) :: Interp - type(axistype), dimension(4) :: axes_data + type(axis_info), dimension(4) :: axes_data integer :: is, ie, js, je ! compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices @@ -728,8 +728,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & if (PRESENT(spongeOngrid)) is_ongrid = spongeOngrid if (.not. is_ongrid) then allocate(lon_in(id), lat_in(jd)) - call get_axis_data(axes_data(1), lon_in) - call get_axis_data(axes_data(2), lat_in) + call get_axis_info(axes_data(1), ax_data=lon_in) + call get_axis_info(axes_data(2), ax_data=lat_in) endif allocate(z_in(kd), z_edges_in(kd+1)) @@ -737,7 +737,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) - call get_axis_data(axes_data(3), z_in) + call get_axis_info(axes_data(3), ax_data=z_in) if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif From e3c82d24668c7329e4699048dbb77a87de5fab52 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 7 Jun 2023 00:24:30 -0400 Subject: [PATCH 64/81] FMS2: Update time_interp_external functions This patch shifts all remaining time_interp_external functions from time_interp_external to equivalent ones in time_interp_external2. Internally, time-interpolated fields are initialized with `ongrid` set to `.true.`, and such fields are assumed to be on-grid. This seems to hold for all existing instances of `time_interp_external`, but needs to be monitored in the future somehow. --- config_src/infra/FMS2/MOM_interp_infra.F90 | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index db471d0fc1..09a9eb0421 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -8,10 +8,10 @@ module MOM_interp_infra use MOM_io, only : get_var_axes_info use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type -use time_interp_external_mod, only : time_interp_external -use time_interp_external_mod, only : init_external_field, time_interp_external_init -use time_interp_external_mod, only : get_external_field_size -use time_interp_external_mod, only : get_external_field_axes, get_external_field_missing +use time_interp_external2_mod, only : time_interp_external +use time_interp_external2_mod, only : init_external_field, time_interp_external_init +use time_interp_external2_mod, only : get_external_field_size +use time_interp_external2_mod, only : get_external_field_missing implicit none ; private @@ -267,12 +267,14 @@ function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & if (present(MOM_Domain)) then field%id = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & - verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & - correct_leap_year_inconsistency=correct_leap_year_inconsistency) + verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency, & + ongrid=.true.) else field%id = init_external_field(file, fieldname, domain=domain, & - verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & - correct_leap_year_inconsistency=correct_leap_year_inconsistency) + verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency, & + ongrid=.true.) endif end function init_extern_field From dd1ee3422252e1bdd8613f3fb58d7807bc59d3c4 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 16 Jun 2023 10:40:57 -0400 Subject: [PATCH 65/81] FMS2: Case-insensitive init_external_field The FMS1 implementation of init_external_field is case-insensitive, but the FMS2 implementation is case-sensitive, which can cause errors in older established input files. This patch sweeps through the fields of the input files and checks for a case-insensitive match (using lowercase()). This requires an additional open/close of the file. --- config_src/infra/FMS2/MOM_interp_infra.F90 | 60 ++++++++++++++++++++-- 1 file changed, 56 insertions(+), 4 deletions(-) diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index 09a9eb0421..0b45b752ae 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -7,7 +7,11 @@ module MOM_interp_infra use MOM_io, only : axis_info use MOM_io, only : get_var_axes_info use MOM_time_manager, only : time_type -use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use MOM_error_handler, only : MOM_error, FATAL +use MOM_string_functions, only : lowercase +use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use netcdf_io_mod, only : FmsNetcdfFile_t, netcdf_file_open, netcdf_file_close +use netcdf_io_mod, only : get_num_variables, get_variable_names use time_interp_external2_mod, only : time_interp_external use time_interp_external2_mod, only : init_external_field, time_interp_external_init use time_interp_external2_mod, only : get_external_field_size @@ -262,16 +266,64 @@ function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & !! a model date of Feb 29. onto a common year on Feb. 28. type(external_field) :: field !< Handle to external field + type(FmsNetcdfFile_t) :: extern_file + ! Local instance of netCDF file used to locate case-insensitive field name + integer :: num_fields + ! Number of fields in external file + character(len=256), allocatable :: extern_fieldnames(:) + ! List of field names in file + ! NOTE: length should NF90_MAX_NAME, but I don't know how to read it + character(len=:), allocatable :: label + ! Case-insensitive match to fieldname in file + logical :: rc + ! Return status + integer :: i + ! Loop index + field%filename = file - field%label = fieldname + + ! FMS2's init_external_field is case sensitive, so we must replicate the + ! case-insensitivity of FMS1. This requires opening the file twice. + + rc = netcdf_file_open(extern_file, file, 'read') + if (.not. rc) then + call MOM_error(FATAL, 'init_extern_file: file ' // trim(file) & + // ' could not be opened.') + endif + + ! TODO: broadcast = .false.? + num_fields = get_num_variables(extern_file) + + allocate(extern_fieldnames(num_fields)) + call get_variable_names(extern_file, extern_fieldnames) + + do i = 1, num_fields + if (lowercase(extern_fieldnames(i)) == lowercase(fieldname)) then + field%label = extern_fieldnames(i) + exit + endif + enddo + + call netcdf_file_close(extern_file) + + if (.not. allocated(field%label)) then + call MOM_error(FATAL, 'init_extern_field: field ' // trim(fieldname) & + // ' not found in ' // trim(file) // '.') + endif + + ! Pass to FMS2 implementation of init_external_field + + ! NOTE: external fields are currently assumed to be on-grid, which holds + ! across the current codebase. In the future, we may need to either enforce + ! this or somehow relax this requirement. if (present(MOM_Domain)) then - field%id = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & + field%id = init_external_field(file, field%label, domain=MOM_domain%mpp_domain, & verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency, & ongrid=.true.) else - field%id = init_external_field(file, fieldname, domain=domain, & + field%id = init_external_field(file, field%label, domain=domain, & verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency, & ongrid=.true.) From 932816eadc22f78335a38c27d950b281da21dcdc Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin Date: Wed, 12 Apr 2023 00:35:05 -0400 Subject: [PATCH 66/81] Implementation of ZB sheme --- .../lateral/MOM_Zanna_Bolton.F90 | 444 ++++++++++++++++++ .../lateral/MOM_hor_visc.F90 | 27 ++ 2 files changed, 471 insertions(+) create mode 100644 src/parameterizations/lateral/MOM_Zanna_Bolton.F90 diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 new file mode 100644 index 0000000000..54abea7907 --- /dev/null +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -0,0 +1,444 @@ +! > Calculates Zanna and Bolton 2020 parameterization +module MOM_Zanna_Bolton + +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : To_North, To_East +use MOM_coms, only : reproducing_sum + +implicit none ; private + +#include + +public Zanna_Bolton_2020, ZB_2020_init + +!> Control structure that contains MEKE parameters and diagnostics handles +type, public :: ZB2020_CS + ! Parameters + logical :: use_ZB2020 !< If true, parameterization works + real :: FGR !< Filter to grid width ratio, nondimensional, + ! k_bc = - FGR^2 * dx * dy / 24 + integer :: ZB_type !< 0 = Zanna Bolton 2020, 1 = Anstey Zanna 2017 + logical :: ZB_sign !< if true, sign corresponds to ZB2020 + integer :: ZB_cons !< 0: nonconservative; 1: conservative without interface; + ! 2: conservative with height + + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output + !>@{ Diagnostic handles + integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 + !>@} + +end type ZB2020_CS + +contains + +subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + ! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "MOM_Zanna_Bolton" ! This module's name. + + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "USE_ZB2020", CS%use_ZB2020, & + "If true, turns on Zanna-Bolton 2020 parameterization", & + default=.false.) + + call get_param(param_file, mdl, "FGR", CS%FGR, & + "The ratio of assumed filter width to grid step", & + units="nondim", default=1.) + + call get_param(param_file, mdl, "ZB_type", CS%ZB_type, & + "Type of parameterization: 0 = ZB2020, 1 = AZ2017", & + default=0) + + call get_param(param_file, mdl, "ZB_sign", CS%ZB_sign, & + "If true, sign as in Zanna-Bolton2020, false - is negative", & + default=.true.) + + call get_param(param_file, mdl, "ZB_cons", CS%ZB_cons, & + "0: nonconservative; 1: conservative without interface; " //& + "2: conservative with height", & + default=0) + + ! Register fields for output from this module. + CS%diag => diag + + CS%id_ZB2020u = register_diag_field('ocean_model', 'ZB2020u', diag%axesCuL, Time, & + 'Zonal Acceleration from Zanna-Bolton 2020', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ZB2020v = register_diag_field('ocean_model', 'ZB2020v', diag%axesCvL, Time, & + 'Meridional Acceleration from Zanna-Bolton 2020', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_KE_ZB2020 = register_diag_field('ocean_model', 'KE_ZB2020', diag%axesTL, Time, & + 'Kinetic Energy Source from Horizontal Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + +end subroutine ZB_2020_init + +!> Baroclinic parameterization is as follows: +!! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf +!! (du/dt, dv/dt) = k_BC * +!! (div(S0) + 1/2 * grad(vort_xy^2 + sh_xy^2 + sh_xx^2)) +!! vort_xy = dv/dx - du/dy - relative vorticity +!! sh_xy = dv/dx + du/dy - shearing deformation (or horizontal shear strain) +!! sh_xx = du/dx - dv/dy - stretching deformation (or horizontal tension) +!! S0 - 2x2 tensor: +!! S0 = vort_xy * (-sh_xy, sh_xx; sh_xx, sh_xy) +!! Relating k_BC to velocity gradient model, +!! k_BC = - FGR^2 * cell_area / 24 = - FGR^2 * dx*dy / 24 +!! where FGR - filter to grid width ratio +!! +!! S - is a tensor of full tendency +!! S = (-vort_xy * sh_xy + 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2), vort_xy * sh_xx; +!! vort_xy * sh_xx, vort_xy * sh_xy + 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2)) +!! So the full parameterization: +!! (du/dt, dv/dt) = k_BC * div(S) +!! In generalized curvilinear orthogonal coordinates (see Griffies 2020, +!! and MOM documentation +!! https://mom6.readthedocs.io/en/dev-gfdl/api/generated/modules/mom_hor_visc.html#f/mom_hor_visc): +!! du/dx -> dy/dx * delta_i (u / dy) +!! dv/dy -> dx/dy * delta_j (v / dx) +!! dv/dx -> dy/dx * delta_i (v / dy) +!! du/dy -> dx/dy * delta_j (u / dx) +!! +!! vort_xy and sh_xy are in the corner of the cell +!! sh_xx in the center of the cell +!! +!! In order to compute divergence of S, its components must be: +!! S_11, S_22 in center of the cells +!! S_12 (=S_21) in the corner +!! +!! The following interpolations are required: +!! sh_xx center -> corner +!! vort_xy, sh_xy corner -> center +subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: fx !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: fy !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + + real, dimension(SZI_(G),SZJ_(G)) :: & + dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] + dy_dxT, & !< Pre-calculated dy/dx at h points [nondim] + dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] + dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] + dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] + sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + vort_xy_center, & ! vort_xy in the center + sh_xy_center, & ! sh_xy in the center + S_11, S_22 ! flux tensor in the cell center, multiplied with interface height [m^2/s^2 * h] + + real, dimension(SZIB_(G),SZJB_(G)) :: & + dx_dyBu, & !< Pre-calculated dx/dy at q points [nondim] + dy_dxBu, & !< Pre-calculated dy/dx at q points [nondim] + dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2] + dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2] + dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] + vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] + sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] + sh_xx_corner, & ! sh_xx in the corner + S_12, & ! flux tensor in the corner, multiplied with interface height [m^2/s^2 * h] + hq ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] + + real, dimension(SZIB_(G),SZJ_(G)) :: & + h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n + + real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] + real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] + real :: h2uq, h2vq ! temporary variables [H2 ~> m2 or kg2 m-4]. + + real :: sum_sq ! squared sum, i.e. 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) + real :: vort_sh ! multiplication of vort_xt and sh_xy + + real :: k_bc ! free constant in parameterization, k_bc < 0, [k_bc] = m^2 + + ! Line 407 of MOM_hor_visc.F90 + 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 + + h_neglect = GV%H_subroundoff ! Line 410 on MOM_hor_visc.F90 + h_neglect3 = h_neglect**3 + + fx(:,:,:) = 0. + fy(:,:,:) = 0. + + ! Calculate metric terms (line 2119 of MOM_hor_visc.F90) + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) + DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + + ! Calculate metric terms (line 2122 of MOM_hor_visc.F90) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) + DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) + enddo ; enddo + + do k=1,nz + + sh_xx(:,:) = 0. + sh_xy(:,:) = 0. + vort_xy(:,:) = 0. + + ! Calculate horizontal tension (line 590 of MOM_hor_visc.F90) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + dudx(i,j) = DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - & + G%IdyCu(I-1,j) * u(I-1,j,k)) + dvdy(i,j) = DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & + G%IdxCv(i,J-1) * v(i,J-1,k)) + sh_xx(i,j) = dudx(i,j) - dvdy(i,j) ! center of the cell + enddo ; enddo + + ! Components for the shearing strain (line 599 of MOM_hor_visc.F90) + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + dvdx(I,J) = DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) + dudy(I,J) = DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) + enddo ; enddo + + ! Shearing strain with free-slip B.C. (line 751 of MOM_hor_visc.F90) + ! We use free-slip as cannot guarantee that non-diagonal stress + ! will accelerate or decelerate currents + ! Note that as there is no stencil operator, set of indices + ! is identical to the previous loop, compared to MOM_hor_visc.F90 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + sh_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) + dudy(I,J) ) ! corner of the cell + enddo ; enddo + + ! Relative vorticity with free-slip B.C. (line 789 of MOM_hor_visc.F90) + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) ! corner of the cell + enddo ; enddo + + ! Corner to center interpolation (line 901 of MOM_hor_visc.F90) + ! lower index as in loop for sh_xy, but minus 1 + ! upper index is identical + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + sh_xy_center(i,j) = 0.25 * ( (sh_xy(I-1,J-1) + sh_xy(I,J)) & + + (sh_xy(I-1,J) + sh_xy(I,J-1)) ) + vort_xy_center(i,j) = 0.25 * ( (vort_xy(I-1,J-1) + vort_xy(I,J)) & + + (vort_xy(I-1,J) + vort_xy(I,J-1)) ) + enddo ; enddo + + ! Center to corner interpolation + ! lower index as in loop for sh_xx + ! upper index as in the same loop, but minus 1 + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + sh_xx_corner(I,J) = 0.25 * ( (sh_xx(i+1,j+1) + sh_xx(i,j)) & + + (sh_xx(i+1,j) + sh_xx(i,j+1))) + enddo ; enddo + + ! WITH land mask (line 622 of MOM_hor_visc.F90) + ! Use of mask eliminates dependence on the + ! values on land + do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + enddo ; enddo + + ! Line 1187 of MOM_hor_visc.F90 + do J=js-1,Jeq ; do I=is-1,Ieq + h2uq = 4.0 * (h_u(I,j) * h_u(I,j+1)) + h2vq = 4.0 * (h_v(i,J) * h_v(i+1,J)) + hq(I,J) = (2.0 * (h2uq * h2vq)) & + / (h_neglect3 + (h2uq + h2vq) * ((h_u(I,j) + h_u(I,j+1)) + (h_v(i,J) + h_v(i+1,J)))) + enddo ; enddo + + ! Form S_11 and S_22 tensors + ! Indices - intersection of loops for + ! sh_xy_center and sh_xx + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + if (CS%ZB_type == 0) then + sum_sq = 0.5 * & + (vort_xy_center(i,j)**2 + sh_xy_center(i,j)**2 + sh_xx(i,j)**2) + elseif (CS%ZB_type == 1) then + sum_sq = 0. + endif + + if (CS%ZB_cons == 1 .or. CS%ZB_cons == 2) then + vort_sh = 0.25 * ( & + (G%areaBu(I-1,J-1) * vort_xy(I-1,J-1) * sh_xy(I-1,J-1) + & + G%areaBu(I ,J ) * vort_xy(I ,J ) * sh_xy(I ,J )) + & + (G%areaBu(I-1,J ) * vort_xy(I-1,J ) * sh_xy(I-1,J ) + & + G%areaBu(I ,J-1) * vort_xy(I ,J-1) * sh_xy(I ,J-1)) & + ) * G%IareaT(i,j) + else if (CS%ZB_cons == 0) then + vort_sh = vort_xy_center(i,j) * sh_xy_center(i,j) + endif + k_bc = - CS%FGR**2 * G%areaT(i,j) / 24. + S_11(i,j) = k_bc * (- vort_sh + sum_sq) + S_22(i,j) = k_bc * (+ vort_sh + sum_sq) + enddo ; enddo + + ! Form S_12 tensor + ! indices correspond to sh_xx_corner loop + do J=Jsq-1,Jeq ; do I=Isq-1,Ieq + if (CS%ZB_cons == 2) then + vort_sh = vort_xy(I,J) * 0.25 * ( & + (h(i+1,j+1,k) * sh_xx(i+1,j+1) + & + h(i ,j ,k) * sh_xx(i ,j )) + & + (h(i+1,j ,k) * sh_xx(i+1,j ) + & + h(i ,j+1,k) * sh_xx(i ,j+1)) & + ) / (hq(I,J) + h_neglect) + else if (CS%ZB_cons == 0 .or. CS%ZB_cons == 1) then + vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) + endif + k_bc = - CS%FGR**2 * G%areaBu(i,j) / 24. + S_12(I,J) = k_bc * vort_sh + enddo ; enddo + + ! Weight with interface height (Line 1478 of MOM_hor_visc.F90) + ! Note that reduction is removed + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + S_11(i,j) = S_11(i,j) * h(i,j,k) + S_22(i,j) = S_22(i,j) * h(i,j,k) + enddo ; enddo + + ! Free slip (Line 1487 of MOM_hor_visc.F90) + do J=js-1,Jeq ; do I=is-1,Ieq + S_12(I,J) = S_12(I,J) * (hq(I,J) * G%mask2dBu(I,J)) + enddo ; enddo + + ! Evaluate 1/h x.Div(h S) (Line 1495 of MOM_hor_visc.F90) + ! Minus occurs because in original file (du/dt) = - div(S), + ! but here is the discretization of div(S) + do j=js,je ; do I=Isq,Ieq + fx(I,j,k) = - ((G%IdyCu(I,j)*(dy2h(i,j) *S_11(i,j) - & + dy2h(i+1,j)*S_11(i+1,j)) + & + G%IdxCu(I,j)*(dx2q(I,J-1)*S_12(I,J-1) - & + dx2q(I,J) *S_12(I,J))) * & + G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) + enddo ; enddo + + ! Evaluate 1/h y.Div(h S) (Line 1517 of MOM_hor_visc.F90) + do J=Jsq,Jeq ; do i=is,ie + fy(i,J,k) = - ((G%IdyCv(i,J)*(dy2q(I-1,J)*S_12(I-1,J) - & + dy2q(I,J) *S_12(I,J)) + & ! NOTE this plus + G%IdxCv(i,J)*(dx2h(i,j) *S_22(i,j) - & + dx2h(i,j+1)*S_22(i,j+1))) * & + G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) + enddo ; enddo + + enddo ! end of k loop + + if (not(CS%ZB_sign)) then + fx(:,:,:) = - fx(:,:,:) + fy(:,:,:) = - fy(:,:,:) + endif + + if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, fx, CS%diag) + if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, fy, CS%diag) + + call compute_energy_source(u, v, h, fx, fy, G, GV, CS) + +end subroutine Zanna_Bolton_2020 + +! This is copy-paste from MOM_diagnostics.F90, specifically 1125 line +subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: fx !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: fy !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + + real :: KE_term(SZI_(G),SZJ_(G),SZK_(GV)) ! A term in the kinetic energy budget + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! temporary array for integration + real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + + type(group_pass_type) :: pass_KE_uv !< A handle used for group halo passes + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + + real :: uh !< Transport through zonal faces = u*h*dy, + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh !< Transport through meridional faces = v*h*dx, + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: global_integral !< Global integral of the energy effect of ZB2020 [W] + + 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 + + if (CS%id_KE_ZB2020 > 0) then + call create_group_pass(pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + + KE_term(:,:,:) = 0. + tmp(:,:,:) = 0. + ! Calculate the KE source from Zanna-Bolton2020 [H L2 T-3 ~> m3 s-3]. + do k=1,nz + KE_u(:,:) = 0. + KE_v(:,:) = 0. + do j=js,je ; do I=Isq,Ieq + uh = u(I,j,k) * 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) * & + G%dyCu(I,j) + KE_u(I,j) = uh * G%dxCu(I,j) * fx(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + vh = v(i,J,k) * 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) * & + G%dxCv(i,J) + KE_v(i,J) = vh * G%dyCv(i,J) * fy(i,J,k) + enddo ; enddo + call do_group_pass(pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + ! copy-paste from MOM_spatial_means.F90, line 42 + tmp(i,j,k) = KE_term(i,j,k) * G%areaT(i,j) * G%mask2dT(i,j) + enddo ; enddo + enddo + + global_integral = reproducing_sum(tmp) + + !write(*,*) 'Global energy rate of change [W] for ZB2020:', global_integral + + call post_data(CS%id_KE_ZB2020, KE_term, CS%diag) + endif + +end subroutine compute_energy_source + +end module MOM_Zanna_Bolton \ No newline at end of file diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index e6dd131a99..b2303bade3 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -23,6 +23,7 @@ module MOM_hor_visc use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_variables, only : accel_diag_ptrs +use MOM_Zanna_Bolton, only : Zanna_Bolton_2020, ZB_2020_init, ZB2020_CS implicit none ; private @@ -105,6 +106,8 @@ module MOM_hor_visc real :: min_grid_Ah !< Minimun horizontal biharmonic viscosity used to !! limit grid Reynolds number [L4 T-1 ~> m4 s-1] + type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. !! The actual viscosity may be the larger of this @@ -329,6 +332,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grid_Re_Kh, & ! Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] GME_coeff_h ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] + + ! Zanna-Bolton fields + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + ZB2020u !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + ZB2020v !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1] @@ -1607,6 +1619,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ! end of k loop + if (CS%ZB2020%use_ZB2020) then + call Zanna_Bolton_2020(u, v, h, ZB2020u, ZB2020v, G, GV, CS%ZB2020) + + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + diffu(I,j,k) = diffu(I,j,k) + ZB2020u(I,j,k) + enddo ; enddo ; enddo + + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + diffv(i,J,k) = diffv(i,J,k) + ZB2020v(i,J,k) + enddo ; enddo ; enddo + endif + ! Offer fields for diagnostic averaging. if (CS%id_normstress > 0) call post_data(CS%id_normstress, NoSt, CS%diag) if (CS%id_shearstress > 0) call post_data(CS%id_shearstress, ShSt, CS%diag) @@ -1753,6 +1777,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + ! init control structure + call ZB_2020_init(Time, GV, US, param_file, diag, CS%ZB2020) + CS%initialized = .true. CS%diag => diag From 1a38b88122a956c5546ca4d891d10be139395c0a Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin Date: Wed, 12 Apr 2023 00:40:30 -0400 Subject: [PATCH 67/81] Filters for ZB. Regression changed (FGR changed to amplitude) --- .../lateral/MOM_Zanna_Bolton.F90 | 526 ++++++++++++++++-- 1 file changed, 470 insertions(+), 56 deletions(-) diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index 54abea7907..7c209eff1f 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -9,7 +9,8 @@ module MOM_Zanna_Bolton use MOM_diag_mediator, only : post_data, register_diag_field use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East -use MOM_coms, only : reproducing_sum +use MOM_domains, only : pass_var, CORNER +use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs implicit none ; private @@ -20,17 +21,30 @@ module MOM_Zanna_Bolton !> Control structure that contains MEKE parameters and diagnostics handles type, public :: ZB2020_CS ! Parameters - logical :: use_ZB2020 !< If true, parameterization works - real :: FGR !< Filter to grid width ratio, nondimensional, - ! k_bc = - FGR^2 * dx * dy / 24 - integer :: ZB_type !< 0 = Zanna Bolton 2020, 1 = Anstey Zanna 2017 - logical :: ZB_sign !< if true, sign corresponds to ZB2020 - integer :: ZB_cons !< 0: nonconservative; 1: conservative without interface; - ! 2: conservative with height - + logical :: use_ZB2020 !< If true, parameterization works + real :: amplitude !< k_bc = - amplitude * cell_area + real :: amp_bottom !< amplitude in the bottom layer; -1 = use same + integer :: ZB_type !< 0 = Full model, 1 = trace-free part, 2 = only trace part + integer :: ZB_cons !< 0: nonconservative; 1: conservative without interface; + integer :: LPF_iter !< Low-pass filter for Velocity gradient; number of iterations + integer :: LPF_order !< Low-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian + integer :: HPF_iter !< High-pass filter for Velocity gradient; number of iterations + integer :: HPF_order !< High-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian + integer :: Stress_iter !< Low-pass filter for Stress (Momentum Flux); number of iterations + integer :: Stress_order !< Low-pass filter for Stress (Momentum Flux); 1: Laplacian, 2: Bilaplacian + integer :: ssd_iter !< Small-scale dissipation in RHS of momentum eq; -1: off, 0:Laplacian, 4:Laplacian^5 + real :: ssd_bound_coef !< the viscosity bounds to the theoretical maximum for stability + + real :: DT !< The (baroclinic) dynamics time step. + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles - integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 + integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1, id_kbc = -1 + integer :: id_maskT = -1 + integer :: id_maskq = -1 + integer :: id_S_11f = -1 + integer :: id_S_22f = -1 + integer :: id_S_12f = -1 !>@} end type ZB2020_CS @@ -39,7 +53,7 @@ module MOM_Zanna_Bolton subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. @@ -53,25 +67,62 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_ZB2020", CS%use_ZB2020, & "If true, turns on Zanna-Bolton 2020 parameterization", & - default=.false.) + default=.true.) - call get_param(param_file, mdl, "FGR", CS%FGR, & - "The ratio of assumed filter width to grid step", & - units="nondim", default=1.) + call get_param(param_file, mdl, "amplitude", CS%amplitude, & + "k_bc=-amplitude*cell_area, amplitude=1/24..1", & + units="nondim", default=1./24.) + + call get_param(param_file, mdl, "amp_bottom", CS%amp_bottom, & + "-1=use same amplitude, or specify", & + units="nondim", default=-1.) + + if (CS%amp_bottom < -0.5) CS%amp_bottom = CS%amplitude call get_param(param_file, mdl, "ZB_type", CS%ZB_type, & - "Type of parameterization: 0 = ZB2020, 1 = AZ2017", & + "Type of parameterization: 0 = full, 1 = trace-free, 2 = trace-only", & default=0) - call get_param(param_file, mdl, "ZB_sign", CS%ZB_sign, & - "If true, sign as in Zanna-Bolton2020, false - is negative", & - default=.true.) - call get_param(param_file, mdl, "ZB_cons", CS%ZB_cons, & - "0: nonconservative; 1: conservative without interface; " //& - "2: conservative with height", & - default=0) + "0: nonconservative; 1: conservative without interface", & + default=1) + + call get_param(param_file, mdl, "LPF_iter", CS%LPF_iter, & + "Low-pass filter for Velocity gradient; number of iterations", & + default=2) + call get_param(param_file, mdl, "LPF_order", CS%LPF_order, & + "Low-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian", & + default=2) + + call get_param(param_file, mdl, "HPF_iter", CS%HPF_iter, & + "High-pass filter for Velocity gradient; number of iterations", & + default=2) + + call get_param(param_file, mdl, "HPF_order", CS%HPF_order, & + "High-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian", & + default=2) + + call get_param(param_file, mdl, "Stress_iter", CS%Stress_iter, & + "Low-pass filter for Stress (Momentum Flux); number of iterations", & + default=2) + + call get_param(param_file, mdl, "Stress_order", CS%Stress_order, & + "Low-pass filter for Stress (Momentum Flux); 1: Laplacian, 2: Bilaplacian", & + default=2) + + call get_param(param_file, mdl, "ssd_iter", CS%ssd_iter, & + "Small-scale dissipation in RHS of momentum eq; -1: off, 0:Laplacian, 4:Laplacian^5", & + default=-1) + + call get_param(param_file, mdl, "ssd_bound_coef", CS%ssd_bound_coef, & + "The viscosity bounds to the theoretical maximum for stability", units="nondim", & + default=0.8) + + call get_param(param_file, mdl, "DT", CS%dt, & + "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & + fail_if_missing=.true.) + ! Register fields for output from this module. CS%diag => diag @@ -82,6 +133,26 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) CS%id_KE_ZB2020 = register_diag_field('ocean_model', 'KE_ZB2020', diag%axesTL, Time, & 'Kinetic Energy Source from Horizontal Viscosity', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_kbc = register_diag_field('ocean_model', 'kbc_ZB2020', diag%axesTL, Time, & + 'Kinetic Energy Source from Horizontal Viscosity', & + 'm2', conversion=US%L_to_m**2) + + ! masks and action of filter on test fields + CS%id_maskT = register_diag_field('ocean_model', 'maskT', diag%axesTL, Time, & + 'mask of wet T points', '1', conversion=1.) + + CS%id_maskq = register_diag_field('ocean_model', 'maskq', diag%axesBL, Time, & + 'mask of wet q points', '1', conversion=1.) + + ! action of filter on momentum flux + CS%id_S_11f = register_diag_field('ocean_model', 'S_11f', diag%axesTL, Time, & + '11 momentum flux filtered', 'm2s-2', conversion=US%L_T_to_m_s**2) + + CS%id_S_22f = register_diag_field('ocean_model', 'S_22f', diag%axesTL, Time, & + '22 momentum flux filtered', 'm2s-2', conversion=US%L_T_to_m_s**2) + + CS%id_S_12f = register_diag_field('ocean_model', 'S_12f', diag%axesBL, Time, & + '12 momentum flux filtered', 'm2s-2', conversion=US%L_T_to_m_s**2) end subroutine ZB_2020_init @@ -95,8 +166,8 @@ end subroutine ZB_2020_init !! S0 - 2x2 tensor: !! S0 = vort_xy * (-sh_xy, sh_xx; sh_xx, sh_xy) !! Relating k_BC to velocity gradient model, -!! k_BC = - FGR^2 * cell_area / 24 = - FGR^2 * dx*dy / 24 -!! where FGR - filter to grid width ratio +!! k_BC = - amplitude * cell_area +!! where amplitude = 1/24..1 (approx) !! !! S - is a tensor of full tendency !! S = (-vort_xy * sh_xy + 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2), vort_xy * sh_xx; @@ -149,7 +220,9 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] vort_xy_center, & ! vort_xy in the center sh_xy_center, & ! sh_xy in the center - S_11, S_22 ! flux tensor in the cell center, multiplied with interface height [m^2/s^2 * h] + S_11, S_22, & ! flux tensor in the cell center, multiplied with interface height [m^2/s^2 * h] + ssd_11, & ! diagonal part of ssd in cell center + mask_T ! mask of wet center points real, dimension(SZIB_(G),SZJB_(G)) :: & dx_dyBu, & !< Pre-calculated dx/dy at q points [nondim] @@ -161,7 +234,19 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] sh_xx_corner, & ! sh_xx in the corner S_12, & ! flux tensor in the corner, multiplied with interface height [m^2/s^2 * h] - hq ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] + ssd_12, & ! off-diagonal part of ssd in corner + hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] + mask_q ! mask of wet corner points + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + kbc_3d, & ! k_bc parameter as 3d field [L2 ~> m2] + mask_T_3d, & + S_11_3df, & + S_22_3df + + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + mask_q_3d, & + S_12_3df real, dimension(SZIB_(G),SZJ_(G)) :: & h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. @@ -177,8 +262,9 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) real :: sum_sq ! squared sum, i.e. 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) real :: vort_sh ! multiplication of vort_xt and sh_xy + real :: amplitude ! amplitude of ZB parameterization - real :: k_bc ! free constant in parameterization, k_bc < 0, [k_bc] = m^2 + real :: k_bc ! free constant in parameterization, k_bc < 0, [k_bc] = m^2 ! Line 407 of MOM_hor_visc.F90 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -189,6 +275,7 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) fx(:,:,:) = 0. fy(:,:,:) = 0. + kbc_3d(:,:,:) = 0. ! Calculate metric terms (line 2119 of MOM_hor_visc.F90) do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 @@ -204,9 +291,15 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) do k=1,nz + if (k==1) amplitude = CS%amplitude + if (k==2) amplitude = CS%amp_bottom + sh_xx(:,:) = 0. sh_xy(:,:) = 0. vort_xy(:,:) = 0. + S_12(:,:) = 0. + S_11(:,:) = 0. + S_22(:,:) = 0. ! Calculate horizontal tension (line 590 of MOM_hor_visc.F90) do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 @@ -236,7 +329,45 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) ! corner of the cell enddo ; enddo + + call compute_masks(G, GV, h, mask_T, mask_q, k) + mask_T_3d(:,:,k) = mask_T(:,:) + mask_q_3d(:,:,k) = mask_q(:,:) + + ! Numerical scheme for ZB2020 requires + ! interpolation center <-> corner + ! This interpolation requires B.C., + ! and that is why B.C. for Velocity Gradients should be + ! well defined + ! The same B.C. will be used by all filtering operators, + ! So, it must be applied + sh_xx(:,:) = sh_xx(:,:) * mask_T(:,:) + sh_xy(:,:) = sh_xy(:,:) * mask_q(:,:) + vort_xy(:,:) = vort_xy(:,:) * mask_q(:,:) + + if (CS%ssd_iter > -1) then + ssd_11(:,:) = sh_xx(:,:) * & + CS%ssd_bound_coef * 0.25 / CS%DT * & + dx2h(:,:) * dy2h(:,:) / (dx2h(:,:) + dy2h(:,:)) + ssd_12(:,:) = sh_xy(:,:) * & + CS%ssd_bound_coef * 0.25 / CS%DT * & + dx2q(:,:) * dy2q(:,:) / (dx2q(:,:) + dy2q(:,:)) + + if (CS%ssd_iter > 0) then + call filter(G, mask_T, mask_q, -1, CS%ssd_iter, T=ssd_11) + call filter(G, mask_T, mask_q, -1, CS%ssd_iter, q=ssd_12) + endif + endif + + call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, T=sh_xx) + call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, T=sh_xx) + call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, q=sh_xy) + call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, q=sh_xy) + + call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, q=vort_xy) + call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, q=vort_xy) + ! Corner to center interpolation (line 901 of MOM_hor_visc.F90) ! lower index as in loop for sh_xy, but minus 1 ! upper index is identical @@ -276,46 +407,61 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) ! Form S_11 and S_22 tensors ! Indices - intersection of loops for ! sh_xy_center and sh_xx - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - if (CS%ZB_type == 0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%ZB_type == 1) then + sum_sq = 0. + else sum_sq = 0.5 * & (vort_xy_center(i,j)**2 + sh_xy_center(i,j)**2 + sh_xx(i,j)**2) - elseif (CS%ZB_type == 1) then - sum_sq = 0. endif - if (CS%ZB_cons == 1 .or. CS%ZB_cons == 2) then - vort_sh = 0.25 * ( & - (G%areaBu(I-1,J-1) * vort_xy(I-1,J-1) * sh_xy(I-1,J-1) + & - G%areaBu(I ,J ) * vort_xy(I ,J ) * sh_xy(I ,J )) + & - (G%areaBu(I-1,J ) * vort_xy(I-1,J ) * sh_xy(I-1,J ) + & - G%areaBu(I ,J-1) * vort_xy(I ,J-1) * sh_xy(I ,J-1)) & - ) * G%IareaT(i,j) - else if (CS%ZB_cons == 0) then - vort_sh = vort_xy_center(i,j) * sh_xy_center(i,j) + if (CS%ZB_type == 2) then + vort_sh = 0. + else + if (CS%ZB_cons == 1) then + vort_sh = 0.25 * ( & + (G%areaBu(I-1,J-1) * vort_xy(I-1,J-1) * sh_xy(I-1,J-1) + & + G%areaBu(I ,J ) * vort_xy(I ,J ) * sh_xy(I ,J )) + & + (G%areaBu(I-1,J ) * vort_xy(I-1,J ) * sh_xy(I-1,J ) + & + G%areaBu(I ,J-1) * vort_xy(I ,J-1) * sh_xy(I ,J-1)) & + ) * G%IareaT(i,j) + else if (CS%ZB_cons == 0) then + vort_sh = vort_xy_center(i,j) * sh_xy_center(i,j) + endif endif - k_bc = - CS%FGR**2 * G%areaT(i,j) / 24. + k_bc = - amplitude * G%areaT(i,j) S_11(i,j) = k_bc * (- vort_sh + sum_sq) S_22(i,j) = k_bc * (+ vort_sh + sum_sq) + + kbc_3d(i,j,k) = k_bc enddo ; enddo ! Form S_12 tensor ! indices correspond to sh_xx_corner loop do J=Jsq-1,Jeq ; do I=Isq-1,Ieq - if (CS%ZB_cons == 2) then - vort_sh = vort_xy(I,J) * 0.25 * ( & - (h(i+1,j+1,k) * sh_xx(i+1,j+1) + & - h(i ,j ,k) * sh_xx(i ,j )) + & - (h(i+1,j ,k) * sh_xx(i+1,j ) + & - h(i ,j+1,k) * sh_xx(i ,j+1)) & - ) / (hq(I,J) + h_neglect) - else if (CS%ZB_cons == 0 .or. CS%ZB_cons == 1) then + if (CS%ZB_type == 2) then + vort_sh = 0. + else vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) endif - k_bc = - CS%FGR**2 * G%areaBu(i,j) / 24. + k_bc = - amplitude * G%areaBu(i,j) S_12(I,J) = k_bc * vort_sh enddo ; enddo + call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_11) + call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_22) + call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, q=S_12) + + S_11_3df(:,:,k) = S_11(:,:) + S_22_3df(:,:,k) = S_22(:,:) + S_12_3df(:,:,k) = S_12(:,:) + + if (CS%ssd_iter>-1) then + S_11(:,:) = S_11(:,:) + ssd_11(:,:) + S_12(:,:) = S_12(:,:) + ssd_12(:,:) + S_22(:,:) = S_22(:,:) - ssd_11(:,:) + endif + ! Weight with interface height (Line 1478 of MOM_hor_visc.F90) ! Note that reduction is removed do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -350,18 +496,286 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) enddo ! end of k loop - if (not(CS%ZB_sign)) then - fx(:,:,:) = - fx(:,:,:) - fy(:,:,:) = - fy(:,:,:) - endif - if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, fx, CS%diag) if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, fy, CS%diag) + if (CS%id_kbc>0) call post_data(CS%id_kbc, kbc_3d, CS%diag) + + if (CS%id_maskT>0) call post_data(CS%id_maskT, mask_T_3d, CS%diag) + if (CS%id_maskq>0) call post_data(CS%id_maskq, mask_q_3d, CS%diag) + + if (CS%id_S_11f>0) call post_data(CS%id_S_11f, S_11_3df, CS%diag) + + if (CS%id_S_22f>0) call post_data(CS%id_S_22f, S_22_3df, CS%diag) + + if (CS%id_S_12f>0) call post_data(CS%id_S_12f, S_12_3df, CS%diag) call compute_energy_source(u, v, h, fx, fy, G, GV, CS) end subroutine Zanna_Bolton_2020 +! if n_lowpass and n_highpass are positive, +! performs n_lowpass iterations of +! filter of order 2*n_highpass +! if n_lowpass is negative, returns residual instead +! Input does not require halo +! Output has full halo +! filtering occurs in-place +subroutine filter(G, mask_T, mask_q, n_lowpass, n_highpass, T, q) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: mask_T !< mask of wet points in T points + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: mask_q !< mask of wet points in q points + real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: T !< any field at T points + real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: q !< any field at q points + integer, intent(in) :: n_lowpass !< number of low-pass iterations + integer, intent(in) :: n_highpass !< number of high-pass iterations + + integer :: i, j + real, dimension(SZIB_(G),SZJB_(G)) :: q1, q2 ! additional q fields + real, dimension(SZI_(G),SZJ_(G)) :: T1, T2 ! additional T fields + real :: max_before, min_before, max_after, min_after ! for testing + + if (n_lowpass==0) then + return + endif + + ! Total operator is I - (I-G^n_lowpass)^n_highpass + if (present(q)) then + call pass_var(q, G%Domain, position=CORNER, complete=.true.) + q(:,:) = q(:,:) * mask_q(:,:) + call min_max(q, min_before, max_before) + + q1(:,:) = q(:,:) + + do i=1,n_highpass + q2(:,:) = q1(:,:) + ! q2 -> (G^n_lowpass)*q2 + do j=1,ABS(n_lowpass) + call smooth_Tq(G, mask_T, mask_q, q=q2) + enddo + ! q1 -> (I-G^n_lowpass)*q1 + q1(:,:) = q1(:,:) - q2(:,:) + enddo + + if (n_lowpass>0) then + ! q -> q - ((I-G^n_lowpass)^n_highpass)*q + q(:,:) = q(:,:) - q1(:,:) + else + ! q -> ((I-G^n_lowpass)^n_highpass)*q + q(:,:) = q1(:,:) + endif + + !call check_nan(q, 'applying filter at q points') + + if (n_highpass==1 .AND. n_lowpass>0) then + call min_max(q, min_after, max_after) + if (max_after > max_before .OR. min_after < min_before) then + write(*,*) 'filter error: not monotone in q field:', min_before, min_after, max_before, max_after + endif + endif + endif + + if (present(T)) then + call pass_var(T, G%Domain) + T(:,:) = T(:,:) * mask_T(:,:) + call min_max(T, min_before, max_before) + + T1(:,:) = T(:,:) + + do i=1,n_highpass + T2(:,:) = T1(:,:) + do j=1,ABS(n_lowpass) + call smooth_Tq(G, mask_T, mask_q, T=T2) + enddo + T1(:,:) = T1(:,:) - T2(:,:) + enddo + + if (n_lowpass>0) then + T(:,:) = T(:,:) - T1(:,:) + else + T(:,:) = T1(:,:) + endif + + !call check_nan(T, 'applying filter at T points') + + if (n_highpass==1 .AND. n_lowpass>0) then + call min_max(T, min_after, max_after) + if (max_after > max_before .OR. min_after < min_before) then + write(*,*) 'filter error: not monotone in T field:', min_before, min_after, max_before, max_after + endif + endif + endif +end subroutine filter + +! returns filtered fields in-place and +! residuals as optional argument +subroutine smooth_Tq(G, mask_T, mask_q, T, q) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: mask_T !< mask of wet points in T points + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: mask_q !< mask of wet points in q points + real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: T !< any field at T points + real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: q !< any field at q points + + real, dimension(SZI_(G),SZJ_(G)) :: Tim ! intermediate value of T-field + real, dimension(SZIB_(G),SZJB_(G)) :: qim ! intermediate value of q-field + + integer :: i, j + real :: wside ! weights for side (i+1,j), (i-1,j), (i,j+1), (i,j-1) + real :: wcorner ! weights for corners (i+1,j+1), (i+1,j-1), (i-1,j-1), (i-1,j+1) + real :: wcenter ! weight for center point (i,j) + + wside = 1. / 8. + wcorner = 1. / 16. + wcenter = 1. - (wside*4. + wcorner*4.) + + if (present(q)) then + call pass_var(q, G%Domain, position=CORNER, complete=.true.) + qim(:,:) = q(:,:) * mask_q(:,:) + do J = G%JscB, G%JecB + do I = G%IscB, G%IecB + q(I,J) = wcenter * qim(I,J) & + + wcorner * qim(I-1,J-1) & + + wcorner * qim(I-1,J+1) & + + wcorner * qim(I+1,J-1) & + + wcorner * qim(I+1,J+1) & + + wside * qim(I-1,J) & + + wside * qim(I+1,J) & + + wside * qim(I,J-1) & + + wside * qim(I,J+1) + q(I,J) = q(I,J) * mask_q(I,J) + enddo + enddo + call pass_var(q, G%Domain, position=CORNER, complete=.true.) + endif + + if (present(T)) then + call pass_var(T, G%Domain) + Tim(:,:) = T(:,:) * mask_T(:,:) + do j = G%jsc, G%jec + do i = G%isc, G%iec + T(i,j) = wcenter * Tim(i,j) & + + wcorner * Tim(i-1,j-1) & + + wcorner * Tim(i-1,j+1) & + + wcorner * Tim(i+1,j-1) & + + wcorner * Tim(i+1,j+1) & + + wside * Tim(i-1,j) & + + wside * Tim(i+1,j) & + + wside * Tim(i,j-1) & + + wside * Tim(i,j+1) + T(i,j) = T(i,j) * mask_T(i,j) + enddo + enddo + call pass_var(T, G%Domain) + endif + +end subroutine smooth_Tq + +subroutine min_max(array, min_val, max_val) + real, dimension(:,:), intent(in) :: array + real, intent(out) :: min_val, max_val + + min_val = minval(array) + max_val = maxval(array) + call min_across_PEs(min_val) + call max_across_PEs(max_val) +end subroutine + +subroutine check_nan(array, str) + !use mpi + use MOM_coms_infra, only : PE_here + real, intent(in) :: array(:,:) + character(*), intent(in) :: str + + integer :: i,j + integer :: nx, ny + logical :: flag = .False. + integer :: ierr + character(100) :: out + + nx = size(array,1) + ny = size(array,2) + + do i=1,nx + do j=1,ny + if (isnan(array(i,j))) then + write(*,'(A,I3,A,I3,A,I3,A,I3,A,I3,A,A)') 'NaN at(',i,',',j,') of (',nx,',',ny,') at PE', PE_here(), ', in ', str + flag = .True. + endif + enddo + enddo + +end subroutine check_nan + +subroutine set_chessnoise(G, T, q) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: T !< any field at T points + real, dimension(SZIB_(G),SZJB_(G)), intent(inout) :: q !< any field at q points + + integer :: i, j, ig, jg + + do j = G%jsd, G%jed + do i = G%isd, G%ied + ig = i + G%idg_offset + jg = j + G%jdg_offset + T(i,j) = (-1.) ** (ig+jg) + enddo + enddo + + do J = G%JsdB, G%JedB + do I = G%IsdB, G%IedB + Ig = I + G%idg_offset + Jg = J + G%jdg_offset + q(I,J) = (-1.) ** (Ig+Jg) + enddo + enddo + +end subroutine set_chessnoise + +subroutine compute_masks(G, GV, h, mask_T, mask_q, k) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + 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(inout) :: mask_T !< mask of wet points in T points + real, dimension(SZIB_(G),SZJB_(G)), intent(inout) :: mask_q !< mask of wet points in q points + integer, intent(in) :: k !< index of vertical layer + + real :: hmin + integer :: i, j + + hmin = GV%Angstrom_H * 2. ! min thickness beyound which we have boundary + + mask_q(:,:) = 0. + do J = G%JscB, G%JecB + do I = G%IscB, G%IecB + if (h(i+1,j+1,k) < hmin .or. & + h(i ,j ,k) < hmin .or. & + h(i+1,j ,k) < hmin .or. & + h(i ,j+1,k) < hmin & + ) then + mask_q(I,J) = 0. + else + mask_q(I,J) = 1. + endif + mask_q(I,J) = mask_q(I,J) * G%mask2dBu(I,J) + enddo + enddo + call pass_var(mask_q, G%Domain, position=CORNER, complete=.true.) + + mask_T(:,:) = 0. + do j = G%jsc, G%jec + do i = G%isc, G%iec + if (h(i,j,k) < hmin) then + mask_T(i,j) = 0. + else + mask_T(i,j) = 1. + endif + mask_T(i,j) = mask_T(i,j) * G%mask2dT(i,j) + enddo + enddo + call pass_var(mask_T, G%Domain) + +end subroutine compute_masks + ! This is copy-paste from MOM_diagnostics.F90, specifically 1125 line subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. From e4db92d7430d51caf89b0396ec52dfde6894b100 Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin Date: Wed, 12 Apr 2023 00:43:47 -0400 Subject: [PATCH 68/81] Rotate test is passed. Regression changed (order of operatrions) --- .../lateral/MOM_Zanna_Bolton.F90 | 36 +++++++++---------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index 7c209eff1f..a7caf6fa90 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -632,15 +632,15 @@ subroutine smooth_Tq(G, mask_T, mask_q, T, q) qim(:,:) = q(:,:) * mask_q(:,:) do J = G%JscB, G%JecB do I = G%IscB, G%IecB - q(I,J) = wcenter * qim(I,J) & - + wcorner * qim(I-1,J-1) & - + wcorner * qim(I-1,J+1) & - + wcorner * qim(I+1,J-1) & - + wcorner * qim(I+1,J+1) & - + wside * qim(I-1,J) & - + wside * qim(I+1,J) & - + wside * qim(I,J-1) & - + wside * qim(I,J+1) + q(I,J) = wcenter * qim(i,j) & + + wcorner * ( & + (qim(I-1,J-1)+qim(I+1,J+1)) & + + (qim(I-1,J+1)+qim(I+1,J-1)) & + ) & + + wside * ( & + (qim(I-1,J)+qim(I+1,J)) & + + (qim(I,J-1)+qim(I,J+1)) & + ) q(I,J) = q(I,J) * mask_q(I,J) enddo enddo @@ -652,15 +652,15 @@ subroutine smooth_Tq(G, mask_T, mask_q, T, q) Tim(:,:) = T(:,:) * mask_T(:,:) do j = G%jsc, G%jec do i = G%isc, G%iec - T(i,j) = wcenter * Tim(i,j) & - + wcorner * Tim(i-1,j-1) & - + wcorner * Tim(i-1,j+1) & - + wcorner * Tim(i+1,j-1) & - + wcorner * Tim(i+1,j+1) & - + wside * Tim(i-1,j) & - + wside * Tim(i+1,j) & - + wside * Tim(i,j-1) & - + wside * Tim(i,j+1) + T(i,j) = wcenter * Tim(i,j) & + + wcorner * ( & + (Tim(i-1,j-1)+Tim(i+1,j+1)) & + + (Tim(i-1,j+1)+Tim(i+1,j-1)) & + ) & + + wside * ( & + (Tim(i-1,j)+Tim(i+1,j)) & + + (Tim(i,j-1)+Tim(i,j+1)) & + ) T(i,j) = T(i,j) * mask_T(i,j) enddo enddo From 475212f8c3ef47db4c48b40721f666815fc20518 Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin Date: Wed, 12 Apr 2023 00:49:23 -0400 Subject: [PATCH 69/81] ZB submitted via PR --- .../lateral/MOM_Zanna_Bolton.F90 | 131 ++++-------------- 1 file changed, 30 insertions(+), 101 deletions(-) diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index a7caf6fa90..3bf10f3bd5 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -23,7 +23,6 @@ module MOM_Zanna_Bolton ! Parameters logical :: use_ZB2020 !< If true, parameterization works real :: amplitude !< k_bc = - amplitude * cell_area - real :: amp_bottom !< amplitude in the bottom layer; -1 = use same integer :: ZB_type !< 0 = Full model, 1 = trace-free part, 2 = only trace part integer :: ZB_cons !< 0: nonconservative; 1: conservative without interface; integer :: LPF_iter !< Low-pass filter for Velocity gradient; number of iterations @@ -39,7 +38,7 @@ module MOM_Zanna_Bolton type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles - integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1, id_kbc = -1 + integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 integer :: id_maskT = -1 integer :: id_maskq = -1 integer :: id_S_11f = -1 @@ -67,17 +66,11 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_ZB2020", CS%use_ZB2020, & "If true, turns on Zanna-Bolton 2020 parameterization", & - default=.true.) + default=.false.) call get_param(param_file, mdl, "amplitude", CS%amplitude, & - "k_bc=-amplitude*cell_area, amplitude=1/24..1", & - units="nondim", default=1./24.) - - call get_param(param_file, mdl, "amp_bottom", CS%amp_bottom, & - "-1=use same amplitude, or specify", & - units="nondim", default=-1.) - - if (CS%amp_bottom < -0.5) CS%amp_bottom = CS%amplitude + "k_bc=-amplitude*cell_area, amplitude=0..1", & + units="nondim", default=0.3) call get_param(param_file, mdl, "ZB_type", CS%ZB_type, & "Type of parameterization: 0 = full, 1 = trace-free, 2 = trace-only", & @@ -89,35 +82,35 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "LPF_iter", CS%LPF_iter, & "Low-pass filter for Velocity gradient; number of iterations", & - default=2) + default=0) call get_param(param_file, mdl, "LPF_order", CS%LPF_order, & "Low-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian", & - default=2) + default=1) call get_param(param_file, mdl, "HPF_iter", CS%HPF_iter, & "High-pass filter for Velocity gradient; number of iterations", & - default=2) + default=0) call get_param(param_file, mdl, "HPF_order", CS%HPF_order, & "High-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian", & - default=2) + default=1) call get_param(param_file, mdl, "Stress_iter", CS%Stress_iter, & "Low-pass filter for Stress (Momentum Flux); number of iterations", & - default=2) + default=0) call get_param(param_file, mdl, "Stress_order", CS%Stress_order, & "Low-pass filter for Stress (Momentum Flux); 1: Laplacian, 2: Bilaplacian", & - default=2) + default=1) call get_param(param_file, mdl, "ssd_iter", CS%ssd_iter, & - "Small-scale dissipation in RHS of momentum eq; -1: off, 0:Laplacian, 4:Laplacian^5", & + "Small-scale dissipation in RHS of momentum eq; -1: off, 0:Laplacian, 10:Laplacian^11", & default=-1) call get_param(param_file, mdl, "ssd_bound_coef", CS%ssd_bound_coef, & "The viscosity bounds to the theoretical maximum for stability", units="nondim", & - default=0.8) + default=0.2) call get_param(param_file, mdl, "DT", CS%dt, & "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & @@ -133,10 +126,7 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) CS%id_KE_ZB2020 = register_diag_field('ocean_model', 'KE_ZB2020', diag%axesTL, Time, & 'Kinetic Energy Source from Horizontal Viscosity', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) - CS%id_kbc = register_diag_field('ocean_model', 'kbc_ZB2020', diag%axesTL, Time, & - 'Kinetic Energy Source from Horizontal Viscosity', & - 'm2', conversion=US%L_to_m**2) - + ! masks and action of filter on test fields CS%id_maskT = register_diag_field('ocean_model', 'maskT', diag%axesTL, Time, & 'mask of wet T points', '1', conversion=1.) @@ -167,7 +157,7 @@ end subroutine ZB_2020_init !! S0 = vort_xy * (-sh_xy, sh_xx; sh_xx, sh_xy) !! Relating k_BC to velocity gradient model, !! k_BC = - amplitude * cell_area -!! where amplitude = 1/24..1 (approx) +!! where amplitude = 0..1 (approx) !! !! S - is a tensor of full tendency !! S = (-vort_xy * sh_xy + 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2), vort_xy * sh_xx; @@ -222,6 +212,7 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) sh_xy_center, & ! sh_xy in the center S_11, S_22, & ! flux tensor in the cell center, multiplied with interface height [m^2/s^2 * h] ssd_11, & ! diagonal part of ssd in cell center + ssd_11_coef, & ! coefficient for diagonal part of ssd [nondim] mask_T ! mask of wet center points real, dimension(SZIB_(G),SZJB_(G)) :: & @@ -235,11 +226,11 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) sh_xx_corner, & ! sh_xx in the corner S_12, & ! flux tensor in the corner, multiplied with interface height [m^2/s^2 * h] ssd_12, & ! off-diagonal part of ssd in corner + ssd_12_coef, & ! coefficient for off-diagonal part of ssd [nondim] hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] mask_q ! mask of wet corner points real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - kbc_3d, & ! k_bc parameter as 3d field [L2 ~> m2] mask_T_3d, & S_11_3df, & S_22_3df @@ -262,7 +253,6 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) real :: sum_sq ! squared sum, i.e. 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) real :: vort_sh ! multiplication of vort_xt and sh_xy - real :: amplitude ! amplitude of ZB parameterization real :: k_bc ! free constant in parameterization, k_bc < 0, [k_bc] = m^2 @@ -275,7 +265,6 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) fx(:,:,:) = 0. fy(:,:,:) = 0. - kbc_3d(:,:,:) = 0. ! Calculate metric terms (line 2119 of MOM_hor_visc.F90) do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 @@ -289,10 +278,12 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) enddo ; enddo - do k=1,nz + if (CS%ssd_iter > -1) then + ssd_11_coef(:,:) = ((CS%ssd_bound_coef * 0.25) / CS%DT) * ((dx2h(:,:) * dy2h(:,:)) / (dx2h(:,:) + dy2h(:,:))) + ssd_12_coef(:,:) = ((CS%ssd_bound_coef * 0.25) / CS%DT) * ((dx2q(:,:) * dy2q(:,:)) / (dx2q(:,:) + dy2q(:,:))) + endif - if (k==1) amplitude = CS%amplitude - if (k==2) amplitude = CS%amp_bottom + do k=1,nz sh_xx(:,:) = 0. sh_xy(:,:) = 0. @@ -331,8 +322,8 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) enddo ; enddo call compute_masks(G, GV, h, mask_T, mask_q, k) - mask_T_3d(:,:,k) = mask_T(:,:) - mask_q_3d(:,:,k) = mask_q(:,:) + if (CS%id_maskT>0) mask_T_3d(:,:,k) = mask_T(:,:) + if (CS%id_maskq>0) mask_q_3d(:,:,k) = mask_q(:,:) ! Numerical scheme for ZB2020 requires ! interpolation center <-> corner @@ -346,12 +337,8 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) vort_xy(:,:) = vort_xy(:,:) * mask_q(:,:) if (CS%ssd_iter > -1) then - ssd_11(:,:) = sh_xx(:,:) * & - CS%ssd_bound_coef * 0.25 / CS%DT * & - dx2h(:,:) * dy2h(:,:) / (dx2h(:,:) + dy2h(:,:)) - ssd_12(:,:) = sh_xy(:,:) * & - CS%ssd_bound_coef * 0.25 / CS%DT * & - dx2q(:,:) * dy2q(:,:) / (dx2q(:,:) + dy2q(:,:)) + ssd_11(:,:) = sh_xx(:,:) * ssd_11_coef(:,:) + ssd_12(:,:) = sh_xy(:,:) * ssd_12_coef(:,:) if (CS%ssd_iter > 0) then call filter(G, mask_T, mask_q, -1, CS%ssd_iter, T=ssd_11) @@ -429,11 +416,9 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) vort_sh = vort_xy_center(i,j) * sh_xy_center(i,j) endif endif - k_bc = - amplitude * G%areaT(i,j) + k_bc = - CS%amplitude * G%areaT(i,j) S_11(i,j) = k_bc * (- vort_sh + sum_sq) S_22(i,j) = k_bc * (+ vort_sh + sum_sq) - - kbc_3d(i,j,k) = k_bc enddo ; enddo ! Form S_12 tensor @@ -444,7 +429,7 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) else vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) endif - k_bc = - amplitude * G%areaBu(i,j) + k_bc = - CS%amplitude * G%areaBu(i,j) S_12(I,J) = k_bc * vort_sh enddo ; enddo @@ -452,9 +437,9 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_22) call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, q=S_12) - S_11_3df(:,:,k) = S_11(:,:) - S_22_3df(:,:,k) = S_22(:,:) - S_12_3df(:,:,k) = S_12(:,:) + if (CS%id_S_11f>0) S_11_3df(:,:,k) = S_11(:,:) + if (CS%id_S_22f>0) S_22_3df(:,:,k) = S_22(:,:) + if (CS%id_S_12f>0) S_12_3df(:,:,k) = S_12(:,:) if (CS%ssd_iter>-1) then S_11(:,:) = S_11(:,:) + ssd_11(:,:) @@ -498,7 +483,6 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, fx, CS%diag) if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, fy, CS%diag) - if (CS%id_kbc>0) call post_data(CS%id_kbc, kbc_3d, CS%diag) if (CS%id_maskT>0) call post_data(CS%id_maskT, mask_T_3d, CS%diag) if (CS%id_maskq>0) call post_data(CS%id_maskq, mask_q_3d, CS%diag) @@ -563,8 +547,6 @@ subroutine filter(G, mask_T, mask_q, n_lowpass, n_highpass, T, q) ! q -> ((I-G^n_lowpass)^n_highpass)*q q(:,:) = q1(:,:) endif - - !call check_nan(q, 'applying filter at q points') if (n_highpass==1 .AND. n_lowpass>0) then call min_max(q, min_after, max_after) @@ -594,8 +576,6 @@ subroutine filter(G, mask_T, mask_q, n_lowpass, n_highpass, T, q) else T(:,:) = T1(:,:) endif - - !call check_nan(T, 'applying filter at T points') if (n_highpass==1 .AND. n_lowpass>0) then call min_max(T, min_after, max_after) @@ -679,57 +659,6 @@ subroutine min_max(array, min_val, max_val) call max_across_PEs(max_val) end subroutine -subroutine check_nan(array, str) - !use mpi - use MOM_coms_infra, only : PE_here - real, intent(in) :: array(:,:) - character(*), intent(in) :: str - - integer :: i,j - integer :: nx, ny - logical :: flag = .False. - integer :: ierr - character(100) :: out - - nx = size(array,1) - ny = size(array,2) - - do i=1,nx - do j=1,ny - if (isnan(array(i,j))) then - write(*,'(A,I3,A,I3,A,I3,A,I3,A,I3,A,A)') 'NaN at(',i,',',j,') of (',nx,',',ny,') at PE', PE_here(), ', in ', str - flag = .True. - endif - enddo - enddo - -end subroutine check_nan - -subroutine set_chessnoise(G, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: T !< any field at T points - real, dimension(SZIB_(G),SZJB_(G)), intent(inout) :: q !< any field at q points - - integer :: i, j, ig, jg - - do j = G%jsd, G%jed - do i = G%isd, G%ied - ig = i + G%idg_offset - jg = j + G%jdg_offset - T(i,j) = (-1.) ** (ig+jg) - enddo - enddo - - do J = G%JsdB, G%JedB - do I = G%IsdB, G%IedB - Ig = I + G%idg_offset - Jg = J + G%jdg_offset - q(I,J) = (-1.) ** (Ig+Jg) - enddo - enddo - -end subroutine set_chessnoise - subroutine compute_masks(G, GV, h, mask_T, mask_q, k) type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure From 7bb452bf9d85af8ae8775917dfedf1ab7b043451 Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin Date: Wed, 12 Apr 2023 01:02:46 -0400 Subject: [PATCH 70/81] ZB: Response to the code review --- .../lateral/MOM_Zanna_Bolton.F90 | 801 +++++++++++------- .../lateral/MOM_hor_visc.F90 | 15 +- 2 files changed, 505 insertions(+), 311 deletions(-) diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index 3bf10f3bd5..500e4a508c 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -11,6 +11,7 @@ module MOM_Zanna_Bolton use MOM_domains, only : To_North, To_East use MOM_domains, only : pass_var, CORNER use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs +use MOM_error_handler, only : MOM_error, WARNING implicit none ; private @@ -18,100 +19,145 @@ module MOM_Zanna_Bolton public Zanna_Bolton_2020, ZB_2020_init -!> Control structure that contains MEKE parameters and diagnostics handles -type, public :: ZB2020_CS +!> Control structure for Zanna-Bolton-2020 parameterization. +type, public :: ZB2020_CS ; private ! Parameters - logical :: use_ZB2020 !< If true, parameterization works - real :: amplitude !< k_bc = - amplitude * cell_area - integer :: ZB_type !< 0 = Full model, 1 = trace-free part, 2 = only trace part - integer :: ZB_cons !< 0: nonconservative; 1: conservative without interface; - integer :: LPF_iter !< Low-pass filter for Velocity gradient; number of iterations - integer :: LPF_order !< Low-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian - integer :: HPF_iter !< High-pass filter for Velocity gradient; number of iterations - integer :: HPF_order !< High-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian - integer :: Stress_iter !< Low-pass filter for Stress (Momentum Flux); number of iterations - integer :: Stress_order !< Low-pass filter for Stress (Momentum Flux); 1: Laplacian, 2: Bilaplacian - integer :: ssd_iter !< Small-scale dissipation in RHS of momentum eq; -1: off, 0:Laplacian, 4:Laplacian^5 - real :: ssd_bound_coef !< the viscosity bounds to the theoretical maximum for stability - - real :: DT !< The (baroclinic) dynamics time step. - + real :: amplitude !< The nondimensional scaling factor in ZB model, + !! typically 0.1 - 10 [nondim]. + integer :: ZB_type !< Select how to compute the trace part of ZB model: + !! 0 - both deviatoric and trace components are computed + !! 1 - only deviatoric component is computed + !! 2 - only trace component is computed + integer :: ZB_cons !< Select a discretization scheme for ZB model + !! 0 - non-conservative scheme + !! 1 - conservative scheme for deviatoric component + integer :: LPF_iter !< Number of smoothing passes for the Velocity Gradient (VG) components + !! in ZB model. + integer :: LPF_order !< The scale selectivity of the smoothing filter + !! 1 - Laplacian filter + !! 2 - Bilaplacian filter + integer :: HPF_iter !< Number of sharpening passes for the Velocity Gradient (VG) components + !! in ZB model. + integer :: HPF_order !< The scale selectivity of the sharpening filter + !! 1 - Laplacian filter + !! 2 - Bilaplacian filter + integer :: Stress_iter !< Number of smoothing passes for the Stress tensor components + !! in ZB model. + integer :: Stress_order !< The scale selectivity of the smoothing filter + !! 1 - Laplacian filter + !! 2 - Bilaplacian filter + integer :: ssd_iter !< Hyperviscosity parameter. Defines the number of sharpening passes + !! in Laplacian viscosity model: + !! -1: hyperviscosity is off + !! 0: Laplacian viscosity + !! 9: (Laplacian)^10 viscosity, ... + real :: ssd_bound_coef !< The non-dimensional damping coefficient of the grid harmonic + !! by hyperviscous dissipation: + !! 0.0: no damping + !! 1.0: grid harmonic is removed after a step in time + real :: DT !< The (baroclinic) dynamics time step [T ~> s] + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 integer :: id_maskT = -1 integer :: id_maskq = -1 - integer :: id_S_11f = -1 - integer :: id_S_22f = -1 - integer :: id_S_12f = -1 + integer :: id_S_11 = -1 + integer :: id_S_22 = -1 + integer :: id_S_12 = -1 !>@} end type ZB2020_CS contains -subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) +!> Read parameters and register output fields +!! used in Zanna_Bolton_2020(). +subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) type(time_type), intent(in) :: Time !< The current model time. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + logical, intent(out) :: use_ZB2020 !< If true, turns on ZB scheme. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_Zanna_Bolton" ! This module's name. call log_version(param_file, mdl, version, "") - - call get_param(param_file, mdl, "USE_ZB2020", CS%use_ZB2020, & - "If true, turns on Zanna-Bolton 2020 parameterization", & - default=.false.) - - call get_param(param_file, mdl, "amplitude", CS%amplitude, & - "k_bc=-amplitude*cell_area, amplitude=0..1", & - units="nondim", default=0.3) - - call get_param(param_file, mdl, "ZB_type", CS%ZB_type, & - "Type of parameterization: 0 = full, 1 = trace-free, 2 = trace-only", & - default=0) - call get_param(param_file, mdl, "ZB_cons", CS%ZB_cons, & - "0: nonconservative; 1: conservative without interface", & - default=1) - - call get_param(param_file, mdl, "LPF_iter", CS%LPF_iter, & - "Low-pass filter for Velocity gradient; number of iterations", & + call get_param(param_file, mdl, "USE_ZB2020", use_ZB2020, & + "If true, turns on Zanna-Bolton-2020 (ZB) " //& + "subgrid momentum parameterization of mesoscale eddies.", default=.false.) + if (.not. use_ZB2020) return + + call get_param(param_file, mdl, "ZB_SCALING", CS%amplitude, & + "The nondimensional scaling factor in ZB model, " //& + "typically 0.1 - 10.", units="nondim", default=0.3) + + call get_param(param_file, mdl, "ZB_TRACE_MODE", CS%ZB_type, & + "Select how to compute the trace part of ZB model:\n" //& + "\t 0 - both deviatoric and trace components are computed\n" //& + "\t 1 - only deviatoric component is computed\n" //& + "\t 2 - only trace component is computed", default=0) + + call get_param(param_file, mdl, "ZB_SCHEME", CS%ZB_cons, & + "Select a discretization scheme for ZB model:\n" //& + "\t 0 - non-conservative scheme\n" //& + "\t 1 - conservative scheme for deviatoric component", default=1) + + call get_param(param_file, mdl, "VG_SMOOTH_PASS", CS%LPF_iter, & + "Number of smoothing passes for the Velocity Gradient (VG) components " //& + "in ZB model.", default=0) + + call get_param(param_file, mdl, "VG_SMOOTH_SEL", CS%LPF_order, & + "The scale selectivity of the smoothing filter " //& + "for VG components:\n" //& + "\t 1 - Laplacian filter\n" //& + "\t 2 - Bilaplacian filter, ...", & + default=1, do_not_log = CS%LPF_iter==0) + + call get_param(param_file, mdl, "VG_SHARP_PASS", CS%HPF_iter, & + "Number of sharpening passes for the Velocity Gradient (VG) components " //& + "in ZB model.", default=0) + + call get_param(param_file, mdl, "VG_SHARP_SEL", CS%HPF_order, & + "The scale selectivity of the sharpening filter " //& + "for VG components:\n" //& + "\t 1 - Laplacian filter\n" //& + "\t 2 - Bilaplacian filter,...", & + default=1, do_not_log = CS%HPF_iter==0) + + call get_param(param_file, mdl, "STRESS_SMOOTH_PASS", CS%Stress_iter, & + "Number of smoothing passes for the Stress tensor components " //& + "in ZB model.", default=0) + + call get_param(param_file, mdl, "STRESS_SMOOTH_SEL", CS%Stress_order, & + "The scale selectivity of the smoothing filter " //& + "for the Stress tensor components:\n" //& + "\t 1 - Laplacian filter\n" //& + "\t 2 - Bilaplacian filter,...", & + default=1, do_not_log = CS%Stress_iter==0) + + call get_param(param_file, mdl, "ZB_HYPERVISC", CS%ssd_iter, & + "Select an additional hyperviscosity to stabilize the ZB model:\n" //& + "\t 0 - off\n" //& + "\t 1 - Laplacian viscosity\n" //& + "\t 10 - (Laplacian)**10 viscosity, ...", & default=0) - - call get_param(param_file, mdl, "LPF_order", CS%LPF_order, & - "Low-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian", & - default=1) + ! Convert to the number of sharpening passes + ! applied to the Laplacian viscosity model + CS%ssd_iter = CS%ssd_iter-1 - call get_param(param_file, mdl, "HPF_iter", CS%HPF_iter, & - "High-pass filter for Velocity gradient; number of iterations", & - default=0) - - call get_param(param_file, mdl, "HPF_order", CS%HPF_order, & - "High-pass filter for Velocity gradient; 1: Laplacian, 2: Bilaplacian", & - default=1) + call get_param(param_file, mdl, "HYPVISC_GRID_DAMP", CS%ssd_bound_coef, & + "The non-dimensional damping coefficient of the grid harmonic " //& + "by hyperviscous dissipation:\n" //& + "\t 0.0 - no damping\n" //& + "\t 1.0 - grid harmonic is removed after a step in time", & + units="nondim", default=0.2, do_not_log = CS%ssd_iter==-1) - call get_param(param_file, mdl, "Stress_iter", CS%Stress_iter, & - "Low-pass filter for Stress (Momentum Flux); number of iterations", & - default=0) - - call get_param(param_file, mdl, "Stress_order", CS%Stress_order, & - "Low-pass filter for Stress (Momentum Flux); 1: Laplacian, 2: Bilaplacian", & - default=1) - - call get_param(param_file, mdl, "ssd_iter", CS%ssd_iter, & - "Small-scale dissipation in RHS of momentum eq; -1: off, 0:Laplacian, 10:Laplacian^11", & - default=-1) - - call get_param(param_file, mdl, "ssd_bound_coef", CS%ssd_bound_coef, & - "The viscosity bounds to the theoretical maximum for stability", units="nondim", & - default=0.2) - call get_param(param_file, mdl, "DT", CS%dt, & "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & fail_if_missing=.true.) @@ -126,74 +172,57 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS) CS%id_KE_ZB2020 = register_diag_field('ocean_model', 'KE_ZB2020', diag%axesTL, Time, & 'Kinetic Energy Source from Horizontal Viscosity', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) - - ! masks and action of filter on test fields + CS%id_maskT = register_diag_field('ocean_model', 'maskT', diag%axesTL, Time, & - 'mask of wet T points', '1', conversion=1.) - + 'Mask of wet points in T (CENTER) points', '1', conversion=1.) + CS%id_maskq = register_diag_field('ocean_model', 'maskq', diag%axesBL, Time, & - 'mask of wet q points', '1', conversion=1.) - + 'Mask of wet points in q (CORNER) points', '1', conversion=1.) + ! action of filter on momentum flux - CS%id_S_11f = register_diag_field('ocean_model', 'S_11f', diag%axesTL, Time, & - '11 momentum flux filtered', 'm2s-2', conversion=US%L_T_to_m_s**2) + CS%id_S_11 = register_diag_field('ocean_model', 'S_11', diag%axesTL, Time, & + 'Diagonal term (11) in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) + + CS%id_S_22 = register_diag_field('ocean_model', 'S_22', diag%axesTL, Time, & + 'Diagonal term (22) in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) - CS%id_S_22f = register_diag_field('ocean_model', 'S_22f', diag%axesTL, Time, & - '22 momentum flux filtered', 'm2s-2', conversion=US%L_T_to_m_s**2) + CS%id_S_12 = register_diag_field('ocean_model', 'S_12', diag%axesBL, Time, & + 'Off-diagonal term in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) - CS%id_S_12f = register_diag_field('ocean_model', 'S_12f', diag%axesBL, Time, & - '12 momentum flux filtered', 'm2s-2', conversion=US%L_T_to_m_s**2) - end subroutine ZB_2020_init -!> Baroclinic parameterization is as follows: +!> Baroclinic Zanna-Bolton-2020 parameterization, see !! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf -!! (du/dt, dv/dt) = k_BC * -!! (div(S0) + 1/2 * grad(vort_xy^2 + sh_xy^2 + sh_xx^2)) +!! We collect all contributions to a tensor S, with components: +!! (S_11, S_12; +!! S_12, S_22) +!! Which consists of the deviatoric and trace components, respectively: +!! S = (-vort_xy * sh_xy, vort_xy * sh_xx; +!! vort_xy * sh_xx, vort_xy * sh_xy) + +!! 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2, 0; +!! 0, vort_xy^2 + sh_xy^2 + sh_xx^2) +!! Where: !! vort_xy = dv/dx - du/dy - relative vorticity !! sh_xy = dv/dx + du/dy - shearing deformation (or horizontal shear strain) !! sh_xx = du/dx - dv/dy - stretching deformation (or horizontal tension) -!! S0 - 2x2 tensor: -!! S0 = vort_xy * (-sh_xy, sh_xx; sh_xx, sh_xy) -!! Relating k_BC to velocity gradient model, -!! k_BC = - amplitude * cell_area -!! where amplitude = 0..1 (approx) -!! -!! S - is a tensor of full tendency -!! S = (-vort_xy * sh_xy + 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2), vort_xy * sh_xx; -!! vort_xy * sh_xx, vort_xy * sh_xy + 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2)) -!! So the full parameterization: +!! Update of the governing equations: !! (du/dt, dv/dt) = k_BC * div(S) -!! In generalized curvilinear orthogonal coordinates (see Griffies 2020, -!! and MOM documentation -!! https://mom6.readthedocs.io/en/dev-gfdl/api/generated/modules/mom_hor_visc.html#f/mom_hor_visc): -!! du/dx -> dy/dx * delta_i (u / dy) -!! dv/dy -> dx/dy * delta_j (v / dx) -!! dv/dx -> dy/dx * delta_i (v / dy) -!! du/dy -> dx/dy * delta_j (u / dx) -!! -!! vort_xy and sh_xy are in the corner of the cell -!! sh_xx in the center of the cell -!! -!! In order to compute divergence of S, its components must be: -!! S_11, S_22 in center of the cells -!! S_12 (=S_21) in the corner -!! -!! The following interpolations are required: -!! sh_xx center -> corner -!! vort_xy, sh_xy corner -> center +!! Where: +!! k_BC = - amplitude * grid_cell_area +!! amplitude = 0.1..10 (approx) + subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - 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_(GV)), & - intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. - + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: fx !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [L T-2 ~> m s-2] @@ -201,60 +230,71 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) intent(out) :: fy !< Meridional acceleration due to convergence !! of along-coordinate stress tensor [L T-2 ~> m s-2] + ! Arrays defined in h (CENTER) points real, dimension(SZI_(G),SZJ_(G)) :: & - dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] - dy_dxT, & !< Pre-calculated dy/dx at h points [nondim] - dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] - dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] - dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] - sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - vort_xy_center, & ! vort_xy in the center - sh_xy_center, & ! sh_xy in the center - S_11, S_22, & ! flux tensor in the cell center, multiplied with interface height [m^2/s^2 * h] - ssd_11, & ! diagonal part of ssd in cell center - ssd_11_coef, & ! coefficient for diagonal part of ssd [nondim] - mask_T ! mask of wet center points - + dx_dyT, & ! dx/dy at h points [nondim] + dy_dxT, & ! dy/dx at h points [nondim] + dx2h, & ! dx^2 at h points [L2 ~> m2] + dy2h, & ! dy^2 at h points [L2 ~> m2] + dudx, dvdy, & ! Components in the horizontal tension [T-1 ~> s-1] + sh_xx, & ! Horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + vort_xy_center, & ! Vorticity interpolated to the center [T-1 ~> s-1] + sh_xy_center, & ! Shearing strain interpolated to the center [T-1 ~> s-1] + S_11, S_22, & ! Diagonal terms in the ZB stress tensor: + ! Above Line 539 [L2 T-2 ~> m2 s-2] + ! Below Line 539 it is layer-integrated [H L2 T-2 ~> m3 s-2 or kg s-2] + ssd_11, & ! Diagonal component of hyperviscous stress [L2 T-2 ~> m2 s-2] + ssd_11_coef, & ! Viscosity coefficient in hyperviscous stress in center points + ! [L2 T-1 ~> m2 s-1] + mask_T ! Mask of wet points in T (CENTER) points [nondim] + + ! Arrays defined in q (CORNER) points real, dimension(SZIB_(G),SZJB_(G)) :: & - dx_dyBu, & !< Pre-calculated dx/dy at q points [nondim] - dy_dxBu, & !< Pre-calculated dy/dx at q points [nondim] - dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2] - dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2] - dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] + dx_dyBu, & ! dx/dy at q points [nondim] + dy_dxBu, & ! dy/dx at q points [nondim] + dx2q, & ! dx^2 at q points [L2 ~> m2] + dy2q, & ! dy^2 at q points [L2 ~> m2] + dvdx, dudy, & ! Components in the shearing strain [T-1 ~> s-1] vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] - sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] - sh_xx_corner, & ! sh_xx in the corner - S_12, & ! flux tensor in the corner, multiplied with interface height [m^2/s^2 * h] - ssd_12, & ! off-diagonal part of ssd in corner - ssd_12_coef, & ! coefficient for off-diagonal part of ssd [nondim] - hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] - mask_q ! mask of wet corner points + sh_xy, & ! Horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] + sh_xx_corner, & ! Horizontal tension interpolated to the corner [T-1 ~> s-1] + S_12, & ! Off-diagonal term in the ZB stress tensor: + ! Above Line 539 [L2 T-2 ~> m2 s-2] + ! Below Line 539 it is layer-integrated [H L2 T-2 ~> m3 s-2 or kg s-2] + ssd_12, & ! Off-diagonal component of hyperviscous stress [L2 T-2 ~> m2 s-2] + ssd_12_coef, & ! Viscosity coefficient in hyperviscous stress in corner points + ! [L2 T-1 ~> m2 s-1] + mask_q ! Mask of wet points in q (CORNER) points [nondim] + + ! Thickness arrays for computing the horizontal divergence of the stress tensor + real, dimension(SZIB_(G),SZJB_(G)) :: & + hq ! Thickness in CORNER points [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - mask_T_3d, & - S_11_3df, & - S_22_3df + mask_T_3d, & ! Mask of wet points in T (CENTER) points [nondim] + S_11_3d, S_22_3d ! Diagonal terms in the ZB stress tensor [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & - mask_q_3d, & - S_12_3df + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + mask_q_3d, & ! Mask of wet points in q (CORNER) points [nondim] + S_12_3d ! Off-diagonal term in the ZB stress tensor [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJ_(G)) :: & - h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & - h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. + real :: h_neglect ! Thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] + real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] + real :: h2uq, h2vq ! Temporary variables [H2 ~> m2 or kg2 m-4]. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: i, j, k, n - - real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] - real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] - real :: h2uq, h2vq ! temporary variables [H2 ~> m2 or kg2 m-4]. + real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) [T-2 ~> s-2] + real :: vort_sh ! vort_xy*sh_xy [T-2 ~> s-2] - real :: sum_sq ! squared sum, i.e. 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) - real :: vort_sh ! multiplication of vort_xt and sh_xy + real :: k_bc ! Constant in from of the parameterization [L2 ~> m2] + ! Related to the amplitude as follows: + ! k_bc = - amplitude * grid_cell_area < 0 - real :: k_bc ! free constant in parameterization, k_bc < 0, [k_bc] = m^2 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n ! Line 407 of MOM_hor_visc.F90 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -279,8 +319,17 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) enddo ; enddo if (CS%ssd_iter > -1) then - ssd_11_coef(:,:) = ((CS%ssd_bound_coef * 0.25) / CS%DT) * ((dx2h(:,:) * dy2h(:,:)) / (dx2h(:,:) + dy2h(:,:))) - ssd_12_coef(:,:) = ((CS%ssd_bound_coef * 0.25) / CS%DT) * ((dx2q(:,:) * dy2q(:,:)) / (dx2q(:,:) + dy2q(:,:))) + ssd_11_coef(:,:) = 0. + ssd_12_coef(:,:) = 0. + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ssd_11_coef(i,j) = ((CS%ssd_bound_coef * 0.25) / CS%DT) & + * ((dx2h(i,j) * dy2h(i,j)) / (dx2h(i,j) + dy2h(i,j))) + enddo; enddo + + do J=js-1,Jeq ; do I=is-1,Ieq + ssd_12_coef(I,J) = ((CS%ssd_bound_coef * 0.25) / CS%DT) & + * ((dx2q(I,J) * dy2q(I,J)) / (dx2q(I,J) + dy2q(I,J))) + enddo; enddo endif do k=1,nz @@ -291,6 +340,8 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) S_12(:,:) = 0. S_11(:,:) = 0. S_22(:,:) = 0. + ssd_11(:,:) = 0. + ssd_12(:,:) = 0. ! Calculate horizontal tension (line 590 of MOM_hor_visc.F90) do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 @@ -320,26 +371,44 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) ! corner of the cell enddo ; enddo - + call compute_masks(G, GV, h, mask_T, mask_q, k) - if (CS%id_maskT>0) mask_T_3d(:,:,k) = mask_T(:,:) - if (CS%id_maskq>0) mask_q_3d(:,:,k) = mask_q(:,:) + if (CS%id_maskT>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + mask_T_3d(i,j,k) = mask_T(i,j) + enddo; enddo + endif - ! Numerical scheme for ZB2020 requires + if (CS%id_maskq>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + mask_q_3d(i,j,k) = mask_q(i,j) + enddo; enddo + endif + + ! Numerical scheme for ZB2020 requires ! interpolation center <-> corner ! This interpolation requires B.C., ! and that is why B.C. for Velocity Gradients should be ! well defined - ! The same B.C. will be used by all filtering operators, - ! So, it must be applied - sh_xx(:,:) = sh_xx(:,:) * mask_T(:,:) - sh_xy(:,:) = sh_xy(:,:) * mask_q(:,:) - vort_xy(:,:) = vort_xy(:,:) * mask_q(:,:) + ! The same B.C. will be used by all filtering operators + do J=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2 + sh_xx(i,j) = sh_xx(i,j) * mask_T(i,j) + enddo ; enddo + + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + sh_xy(i,j) = sh_xy(i,j) * mask_q(i,j) + vort_xy(i,j) = vort_xy(i,j) * mask_q(i,j) + enddo ; enddo if (CS%ssd_iter > -1) then - ssd_11(:,:) = sh_xx(:,:) * ssd_11_coef(:,:) - ssd_12(:,:) = sh_xy(:,:) * ssd_12_coef(:,:) - + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ssd_11(i,j) = sh_xx(i,j) * ssd_11_coef(i,j) + enddo; enddo + + do J=js-1,Jeq ; do I=is-1,Ieq + ssd_12(I,J) = sh_xy(I,J) * ssd_12_coef(I,J) + enddo; enddo + if (CS%ssd_iter > 0) then call filter(G, mask_T, mask_q, -1, CS%ssd_iter, T=ssd_11) call filter(G, mask_T, mask_q, -1, CS%ssd_iter, q=ssd_12) @@ -354,10 +423,10 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, q=vort_xy) call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, q=vort_xy) - + ! Corner to center interpolation (line 901 of MOM_hor_visc.F90) ! lower index as in loop for sh_xy, but minus 1 - ! upper index is identical + ! upper index is identical do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 sh_xy_center(i,j) = 0.25 * ( (sh_xy(I-1,J-1) + sh_xy(I,J)) & + (sh_xy(I-1,J) + sh_xy(I,J-1)) ) @@ -374,7 +443,7 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) enddo ; enddo ! WITH land mask (line 622 of MOM_hor_visc.F90) - ! Use of mask eliminates dependence on the + ! Use of mask eliminates dependence on the ! values on land do j=js-2,je+2 ; do I=Isq-1,Ieq+1 h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) @@ -395,22 +464,22 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) ! Indices - intersection of loops for ! sh_xy_center and sh_xx do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (CS%ZB_type == 1) then + if (CS%ZB_type == 1) then sum_sq = 0. else sum_sq = 0.5 * & (vort_xy_center(i,j)**2 + sh_xy_center(i,j)**2 + sh_xx(i,j)**2) endif - + if (CS%ZB_type == 2) then vort_sh = 0. else if (CS%ZB_cons == 1) then vort_sh = 0.25 * ( & (G%areaBu(I-1,J-1) * vort_xy(I-1,J-1) * sh_xy(I-1,J-1) + & - G%areaBu(I ,J ) * vort_xy(I ,J ) * sh_xy(I ,J )) + & + G%areaBu(I ,J ) * vort_xy(I ,J ) * sh_xy(I ,J )) + & (G%areaBu(I-1,J ) * vort_xy(I-1,J ) * sh_xy(I-1,J ) + & - G%areaBu(I ,J-1) * vort_xy(I ,J-1) * sh_xy(I ,J-1)) & + G%areaBu(I ,J-1) * vort_xy(I ,J-1) * sh_xy(I ,J-1)) & ) * G%IareaT(i,j) else if (CS%ZB_cons == 0) then vort_sh = vort_xy_center(i,j) * sh_xy_center(i,j) @@ -426,7 +495,7 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) do J=Jsq-1,Jeq ; do I=Isq-1,Ieq if (CS%ZB_type == 2) then vort_sh = 0. - else + else vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) endif k_bc = - CS%amplitude * G%areaBu(i,j) @@ -436,15 +505,33 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_11) call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_22) call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, q=S_12) - - if (CS%id_S_11f>0) S_11_3df(:,:,k) = S_11(:,:) - if (CS%id_S_22f>0) S_22_3df(:,:,k) = S_22(:,:) - if (CS%id_S_12f>0) S_12_3df(:,:,k) = S_12(:,:) if (CS%ssd_iter>-1) then - S_11(:,:) = S_11(:,:) + ssd_11(:,:) - S_12(:,:) = S_12(:,:) + ssd_12(:,:) - S_22(:,:) = S_22(:,:) - ssd_11(:,:) + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + S_11(i,j) = S_11(i,j) + ssd_11(i,j) + S_22(i,j) = S_22(i,j) - ssd_11(i,j) + enddo ; enddo + do J=js-1,Jeq ; do I=is-1,Ieq + S_12(I,J) = S_12(I,J) + ssd_12(I,J) + enddo ; enddo + endif + + if (CS%id_S_11>0) then + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + S_11_3d(i,j,k) = S_11(i,j) + enddo; enddo + endif + + if (CS%id_S_22>0) then + do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + S_22_3d(i,j,k) = S_22(i,j) + enddo; enddo + endif + + if (CS%id_S_12>0) then + do J=js-1,Jeq ; do I=is-1,Ieq + S_12_3d(I,J,k) = S_12(I,J) + enddo; enddo endif ! Weight with interface height (Line 1478 of MOM_hor_visc.F90) @@ -483,41 +570,58 @@ subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, fx, CS%diag) if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, fy, CS%diag) - + if (CS%id_maskT>0) call post_data(CS%id_maskT, mask_T_3d, CS%diag) if (CS%id_maskq>0) call post_data(CS%id_maskq, mask_q_3d, CS%diag) - - if (CS%id_S_11f>0) call post_data(CS%id_S_11f, S_11_3df, CS%diag) - if (CS%id_S_22f>0) call post_data(CS%id_S_22f, S_22_3df, CS%diag) + if (CS%id_S_11>0) call post_data(CS%id_S_11, S_11_3d, CS%diag) - if (CS%id_S_12f>0) call post_data(CS%id_S_12f, S_12_3df, CS%diag) + if (CS%id_S_22>0) call post_data(CS%id_S_22, S_22_3d, CS%diag) + + if (CS%id_S_12>0) call post_data(CS%id_S_12, S_12_3d, CS%diag) call compute_energy_source(u, v, h, fx, fy, G, GV, CS) end subroutine Zanna_Bolton_2020 -! if n_lowpass and n_highpass are positive, -! performs n_lowpass iterations of -! filter of order 2*n_highpass -! if n_lowpass is negative, returns residual instead -! Input does not require halo -! Output has full halo -! filtering occurs in-place +!> Filter which is used to smooth velocity gradient tensor +!! or the stress tensor. +!! If n_lowpass and n_highpass are positive, +!! the filter is given by: +!! I - (I-G^n_lowpass)^n_highpass +!! where I is the identity matrix and G is smooth_Tq(). +!! It is filter of order 2*n_highpass, +!! where n_lowpass is the number of iterations +!! which defines the filter scale. +!! If n_lowpass is negative, returns residual +!! for the same filter: +!! (I-G^|n_lowpass|)^n_highpass +!! Input does not require halo. Output has full halo. subroutine filter(G, mask_T, mask_q, n_lowpass, n_highpass, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: mask_T !< mask of wet points in T points - real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: mask_q !< mask of wet points in q points - real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: T !< any field at T points - real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: q !< any field at q points - integer, intent(in) :: n_lowpass !< number of low-pass iterations - integer, intent(in) :: n_highpass !< number of high-pass iterations - + type(ocean_grid_type), intent(in) :: G !< Ocean grid + integer, intent(in) :: n_lowpass !< number of low-pass iterations + integer, intent(in) :: n_highpass !< number of high-pass iterations + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: mask_T !< mask of wet points in T (CENTER) points [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: mask_q !< mask of wet points in q (CORNER) points [nondim] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G)), & + optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] + + real, dimension(SZIB_(G),SZJB_(G)) :: q1, q2 ! intermediate q-fields [arbitrary] + real, dimension(SZI_(G),SZJ_(G)) :: T1, T2 ! intermediate T-fields [arbitrary] + real :: max_before, min_before, max_after, min_after ! minimum and maximum values of fields + ! before and after filtering [arbitrary] + + integer :: i_highpass, i_lowpass integer :: i, j - real, dimension(SZIB_(G),SZJB_(G)) :: q1, q2 ! additional q fields - real, dimension(SZI_(G),SZJ_(G)) :: T1, T2 ! additional T fields - real :: max_before, min_before, max_after, min_after ! for testing - + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + if (n_lowpass==0) then return endif @@ -525,93 +629,149 @@ subroutine filter(G, mask_T, mask_q, n_lowpass, n_highpass, T, q) ! Total operator is I - (I-G^n_lowpass)^n_highpass if (present(q)) then call pass_var(q, G%Domain, position=CORNER, complete=.true.) - q(:,:) = q(:,:) * mask_q(:,:) - call min_max(q, min_before, max_before) + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + q(I,J) = q(I,J) * mask_q(I,J) + enddo ; enddo + + if (n_highpass==1 .AND. n_lowpass>0) then + call min_max(G, min_before, max_before, q=q) + endif + + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + q1(I,J) = q(I,J) + enddo ; enddo - q1(:,:) = q(:,:) - - do i=1,n_highpass - q2(:,:) = q1(:,:) + ! q1 -> ((I-G^n_lowpass)^n_highpass)*q1 + do i_highpass=1,n_highpass + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + q2(I,J) = q1(I,J) + enddo ; enddo ! q2 -> (G^n_lowpass)*q2 - do j=1,ABS(n_lowpass) + do i_lowpass=1,ABS(n_lowpass) call smooth_Tq(G, mask_T, mask_q, q=q2) enddo ! q1 -> (I-G^n_lowpass)*q1 - q1(:,:) = q1(:,:) - q2(:,:) + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + q1(I,J) = q1(I,J) - q2(I,J) + enddo ; enddo enddo if (n_lowpass>0) then ! q -> q - ((I-G^n_lowpass)^n_highpass)*q - q(:,:) = q(:,:) - q1(:,:) + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + q(I,J) = q(I,J) - q1(I,J) + enddo ; enddo else ! q -> ((I-G^n_lowpass)^n_highpass)*q - q(:,:) = q1(:,:) + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + q(I,J) = q1(I,J) + enddo ; enddo endif if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(q, min_after, max_after) + call min_max(G, min_after, max_after, q=q) if (max_after > max_before .OR. min_after < min_before) then - write(*,*) 'filter error: not monotone in q field:', min_before, min_after, max_before, max_after + call MOM_error(WARNING, "MOM_Zanna_Bolton.F90, filter applied in CORNER points "//& + "does not preserve [min,max] values. There may be issues with "//& + "boundary conditions") endif endif endif if (present(T)) then call pass_var(T, G%Domain) - T(:,:) = T(:,:) * mask_T(:,:) - call min_max(T, min_before, max_before) - - T1(:,:) = T(:,:) - - do i=1,n_highpass - T2(:,:) = T1(:,:) - do j=1,ABS(n_lowpass) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + T(i,j) = T(i,j) * mask_T(i,j) + enddo ; enddo + + if (n_highpass==1 .AND. n_lowpass>0) then + call min_max(G, min_before, max_before, T=T) + endif + + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + T1(i,j) = T(i,j) + enddo ; enddo + + do i_highpass=1,n_highpass + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + T2(i,j) = T1(i,j) + enddo ; enddo + do i_lowpass=1,ABS(n_lowpass) call smooth_Tq(G, mask_T, mask_q, T=T2) enddo - T1(:,:) = T1(:,:) - T2(:,:) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + T1(i,j) = T1(i,j) - T2(i,j) + enddo ; enddo enddo if (n_lowpass>0) then - T(:,:) = T(:,:) - T1(:,:) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + T(i,j) = T(i,j) - T1(i,j) + enddo ; enddo else - T(:,:) = T1(:,:) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + T(i,j) = T1(i,j) + enddo ; enddo endif if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(T, min_after, max_after) + call min_max(G, min_after, max_after, T=T) if (max_after > max_before .OR. min_after < min_before) then - write(*,*) 'filter error: not monotone in T field:', min_before, min_after, max_before, max_after + call MOM_error(WARNING, "MOM_Zanna_Bolton.F90, filter applied in CENTER points "//& + " does not preserve [min,max] values. There may be issues with "//& + " boundary conditions") endif endif endif end subroutine filter -! returns filtered fields in-place and -! residuals as optional argument +!> One iteration of 3x3 filter +!! [1 2 1; +!! 2 4 2; +!! 1 2 1]/16 +!! removing chess-harmonic. +!! It is used as a buiding block in filter(). +!! Zero Dirichlet boundary conditions are applied +!! with mask_T and mask_q. subroutine smooth_Tq(G, mask_T, mask_q, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: mask_T !< mask of wet points in T points - real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: mask_q !< mask of wet points in q points - real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: T !< any field at T points - real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: q !< any field at q points - - real, dimension(SZI_(G),SZJ_(G)) :: Tim ! intermediate value of T-field - real, dimension(SZIB_(G),SZJB_(G)) :: qim ! intermediate value of q-field + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: mask_T !< mask of wet points in T (CENTER) points [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: mask_q !< mask of wet points in q (CORNER) points [nondim] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G)), & + optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] + + real, dimension(SZI_(G),SZJ_(G)) :: Tim ! intermediate T-field [arbitrary] + real, dimension(SZIB_(G),SZJB_(G)) :: qim ! intermediate q-field [arbitrary] + + real :: wside ! weights for side points + ! (i+1,j), (i-1,j), (i,j+1), (i,j-1) + ! [nondim] + real :: wcorner ! weights for corner points + ! (i+1,j+1), (i+1,j-1), (i-1,j-1), (i-1,j+1) + ! [nondim] + real :: wcenter ! weight for the center point (i,j) [nondim] integer :: i, j - real :: wside ! weights for side (i+1,j), (i-1,j), (i,j+1), (i,j-1) - real :: wcorner ! weights for corners (i+1,j+1), (i+1,j-1), (i-1,j-1), (i-1,j+1) - real :: wcenter ! weight for center point (i,j) - + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + wside = 1. / 8. wcorner = 1. / 16. wcenter = 1. - (wside*4. + wcorner*4.) if (present(q)) then call pass_var(q, G%Domain, position=CORNER, complete=.true.) - qim(:,:) = q(:,:) * mask_q(:,:) - do J = G%JscB, G%JecB - do I = G%IscB, G%IecB + do J = Jsq-1, Jeq+1; do I = Isq-1, Ieq+1 + qim(I,J) = q(I,J) * mask_q(I,J) + enddo; enddo + do J = Jsq, Jeq + do I = Isq, Ieq q(I,J) = wcenter * qim(i,j) & + wcorner * ( & (qim(I-1,J-1)+qim(I+1,J+1)) & @@ -629,9 +789,11 @@ subroutine smooth_Tq(G, mask_T, mask_q, T, q) if (present(T)) then call pass_var(T, G%Domain) - Tim(:,:) = T(:,:) * mask_T(:,:) - do j = G%jsc, G%jec - do i = G%isc, G%iec + do j = js-1, je+1; do i = is-1, ie+1 + Tim(i,j) = T(i,j) * mask_T(i,j) + enddo; enddo + do j = js, je + do i = is, ie T(i,j) = wcenter * Tim(i,j) & + wcorner * ( & (Tim(i-1,j-1)+Tim(i+1,j+1)) & @@ -649,29 +811,56 @@ subroutine smooth_Tq(G, mask_T, mask_q, T, q) end subroutine smooth_Tq -subroutine min_max(array, min_val, max_val) - real, dimension(:,:), intent(in) :: array - real, intent(out) :: min_val, max_val - - min_val = minval(array) - max_val = maxval(array) +!> Returns min and max values of array across all PEs. +!! It is used in filter() to check its monotonicity. +subroutine min_max(G, min_val, max_val, T, q) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G)), & + optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] + real, intent(out) :: min_val, max_val !< min and max values of array accross PEs [arbitrary] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (present(q)) then + min_val = minval(q(Isq:Ieq, Jsq:Jeq)) + max_val = maxval(q(Isq:Ieq, Jsq:Jeq)) + endif + + if (present(T)) then + min_val = minval(T(is:ie, js:je)) + max_val = maxval(T(is:ie, js:je)) + endif + call min_across_PEs(min_val) call max_across_PEs(max_val) + end subroutine +!> Computes mask of wet points in T (CENTER) and q (CORNER) points. +!! Method: compare layer thicknesses with Angstrom_H. +!! Mask is computed separately for every vertical layer and +!! for every time step. subroutine compute_masks(G, GV, h, mask_T, mask_q, k) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + 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(inout) :: mask_T !< mask of wet points in T points - real, dimension(SZIB_(G),SZJB_(G)), intent(inout) :: mask_q !< mask of wet points in q points - integer, intent(in) :: k !< index of vertical layer - - real :: hmin + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: mask_T !< mask of wet points in T (CENTER) points [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: mask_q !< mask of wet points in q (CORNER) points [nondim] + integer, intent(in) :: k !< index of vertical layer + + real :: hmin ! Minimum layer thickness + ! beyond which we have boundary [H ~> m or kg m-2] integer :: i, j - hmin = GV%Angstrom_H * 2. ! min thickness beyound which we have boundary + hmin = GV%Angstrom_H * 2. mask_q(:,:) = 0. do J = G%JscB, G%JecB @@ -705,53 +894,57 @@ subroutine compute_masks(G, GV, h, mask_T, mask_q, k) end subroutine compute_masks -! This is copy-paste from MOM_diagnostics.F90, specifically 1125 line +!> Computes the 3D energy source term for the ZB2020 scheme +!! similarly to MOM_diagnostics.F90, specifically 1125 line. subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - 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_(GV)), & - intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. - + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: fx !< Zonal acceleration due to convergence of - !! along-coordinate stress tensor [L T-2 ~> m s-2] + intent(in) :: fx !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: fy !< Meridional acceleration due to convergence - !! of along-coordinate stress tensor [L T-2 ~> m s-2] - + intent(in) :: fy !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + real :: KE_term(SZI_(G),SZJ_(G),SZK_(GV)) ! A term in the kinetic energy budget - ! [H L2 T-3 ~> m3 s-3 or W m-2] - real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! temporary array for integration - real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + + !real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! temporary array for integration + !real :: global_integral ! Global integral of the energy effect of ZB2020 + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - type(group_pass_type) :: pass_KE_uv !< A handle used for group halo passes + + real :: uh ! Transport through zonal faces = u*h*dy, + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh ! Transport through meridional faces = v*h*dx, + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. + + type(group_pass_type) :: pass_KE_uv ! A handle used for group halo passes integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k - real :: uh !< Transport through zonal faces = u*h*dy, - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vh !< Transport through meridional faces = v*h*dx, - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: global_integral !< Global integral of the energy effect of ZB2020 [W] - 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 - + if (CS%id_KE_ZB2020 > 0) then call create_group_pass(pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) - + KE_term(:,:,:) = 0. - tmp(:,:,:) = 0. + !tmp(:,:,:) = 0. ! Calculate the KE source from Zanna-Bolton2020 [H L2 T-3 ~> m3 s-3]. do k=1,nz KE_u(:,:) = 0. @@ -771,13 +964,11 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) ! copy-paste from MOM_spatial_means.F90, line 42 - tmp(i,j,k) = KE_term(i,j,k) * G%areaT(i,j) * G%mask2dT(i,j) + !tmp(i,j,k) = KE_term(i,j,k) * G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo enddo - global_integral = reproducing_sum(tmp) - - !write(*,*) 'Global energy rate of change [W] for ZB2020:', global_integral + !global_integral = reproducing_sum(tmp) call post_data(CS%id_KE_ZB2020, KE_term, CS%diag) endif diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index b2303bade3..9037c71c5a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -107,6 +107,7 @@ module MOM_hor_visc !! limit grid Reynolds number [L4 T-1 ~> m4 s-1] type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. + logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. @@ -335,12 +336,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Zanna-Bolton fields real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & - ZB2020u !< Zonal acceleration due to convergence of - !! along-coordinate stress tensor [L T-2 ~> m s-2] + ZB2020u !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & ZB2020v !< Meridional acceleration due to convergence - !! of along-coordinate stress tensor [L T-2 ~> m s-2] - + !! of along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1] @@ -1619,7 +1622,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ! end of k loop - if (CS%ZB2020%use_ZB2020) then + if (CS%use_ZB2020) then call Zanna_Bolton_2020(u, v, h, ZB2020u, ZB2020v, G, GV, CS%ZB2020) do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -1778,7 +1781,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! init control structure - call ZB_2020_init(Time, GV, US, param_file, diag, CS%ZB2020) + call ZB_2020_init(Time, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) CS%initialized = .true. From 1f0c92f9f98a92d0ec9514543a395c263d4be376 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 26 Jun 2023 17:42:44 -0400 Subject: [PATCH 71/81] Update icebergs source path in nolibs build The icebergs project now includes drivers and tests which can interfere with the coupled nolibs build, so we only pass its src directory to mkmf. --- .gitlab/pipeline-ci-tool.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh index a671fe8b23..77409d29ef 100755 --- a/.gitlab/pipeline-ci-tool.sh +++ b/.gitlab/pipeline-ci-tool.sh @@ -154,7 +154,7 @@ nolibs-ocean-ice-compile () { mkdir -p build-ocean-ice-nolibs-$1 cd build-ocean-ice-nolibs-$1 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} + ../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/icebergs/src ../src/{FMS1,coupler,ice_param,land_null,atmos_null} sed -i '/FMS1\/.*\/test_/d' 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) From 201e7058f395350154164e9eaaff4213ff2b9d95 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Jan 2023 17:36:19 -0500 Subject: [PATCH 72/81] +Make units argument mandatory for get_param_real This commit includes changes to the get_param_real and log_param_real interfaces to make the units arguments mandatory. It also adds an optional unscale argument to the log_param_real interfaces. Without other changes in the previous commits, it will cause the MOM6 code to fail to compile. However, by itself this commit does not change any answers or output. --- src/framework/MOM_file_parser.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index fd447f5193..35d75cff7f 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1419,7 +1419,7 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & real, intent(in) :: value !< The value of the parameter to log character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file @@ -1457,7 +1457,7 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & real, dimension(:), intent(in) :: value !< The value of the parameter to log character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file @@ -1782,7 +1782,7 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & !! read from the parameter file and logged character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file @@ -1830,7 +1830,7 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & !! read from the parameter file and logged character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file From cc1784c2a88c19e859de6268bc67e4f0e1f5f1f5 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 12 Dec 2022 15:51:55 -0500 Subject: [PATCH 73/81] github workflows: update to use actions/checkout@v3 - Update actions/checkout from v2 to v3 (suggested at https://github.com/NCAR/MOM6/pull/231#issuecomment-1347224581 thanks to @jedwards4b) --- .github/workflows/coupled-api.yml | 2 +- .github/workflows/coverage.yml | 2 +- .github/workflows/documentation-and-style.yml | 2 +- .github/workflows/expression.yml | 2 +- .github/workflows/macos-regression.yml | 2 +- .github/workflows/macos-stencil.yml | 2 +- .github/workflows/other.yml | 2 +- .github/workflows/perfmon.yml | 2 +- .github/workflows/regression.yml | 2 +- .github/workflows/stencil.yml | 2 +- 10 files changed, 10 insertions(+), 10 deletions(-) diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml index 2c9fa32720..4a07c0b639 100644 --- a/.github/workflows/coupled-api.yml +++ b/.github/workflows/coupled-api.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 358d48a7a7..9922840420 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/documentation-and-style.yml b/.github/workflows/documentation-and-style.yml index c171c538d5..3ca7f0e613 100644 --- a/.github/workflows/documentation-and-style.yml +++ b/.github/workflows/documentation-and-style.yml @@ -8,7 +8,7 @@ jobs: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/expression.yml b/.github/workflows/expression.yml index adedf630b9..5860d32e37 100644 --- a/.github/workflows/expression.yml +++ b/.github/workflows/expression.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/macos-regression.yml b/.github/workflows/macos-regression.yml index dc86a52212..422c50b68a 100644 --- a/.github/workflows/macos-regression.yml +++ b/.github/workflows/macos-regression.yml @@ -16,7 +16,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/macos-stencil.yml b/.github/workflows/macos-stencil.yml index 96240f31f8..36a5841bb2 100644 --- a/.github/workflows/macos-stencil.yml +++ b/.github/workflows/macos-stencil.yml @@ -16,7 +16,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml index c992c8c6ec..2cba17ae76 100644 --- a/.github/workflows/other.yml +++ b/.github/workflows/other.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml index 896b9d51d8..09b4d617a2 100644 --- a/.github/workflows/perfmon.yml +++ b/.github/workflows/perfmon.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/regression.yml b/.github/workflows/regression.yml index 15dcdbceb2..7cdd0a5cd6 100644 --- a/.github/workflows/regression.yml +++ b/.github/workflows/regression.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive diff --git a/.github/workflows/stencil.yml b/.github/workflows/stencil.yml index 6f4a7b1790..c85945072c 100644 --- a/.github/workflows/stencil.yml +++ b/.github/workflows/stencil.yml @@ -11,7 +11,7 @@ jobs: working-directory: .testing steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 with: submodules: recursive From 042eee7d697b207fa7cc16d14724b3153c757aad Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 23 Jun 2023 13:52:19 -0400 Subject: [PATCH 74/81] FMS2: Safe inspection of unlimited dim name The FMS2 function `get_unlimited_dimension_name` raises a netCDF error if no unlimited dimension is found. This is problematic for legacy or externally created input files which may have not identifed their time axis as unlimited. This patch adds a new function, `find_unlimited_dimension_name` which mirrors the FMS2 function but returns an empty string if none are found. This is an internal function, not intended for use outside of the module. --- config_src/infra/FMS2/MOM_io_infra.F90 | 47 ++++++++++++++++++++++---- 1 file changed, 40 insertions(+), 7 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 2c3a5b8ad3..99d0ac3345 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -17,6 +17,7 @@ module MOM_io_infra use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions use fms2_io_mod, only : get_variable_dimension_names, is_dimension_registered, get_dimension_size use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited +use fms2_io_mod, only : get_dimension_names 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 @@ -335,7 +336,7 @@ subroutine open_file(IO_handle, filename, action, MOM_domain, threading, fileset 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) + dim_unlim_name = find_unlimited_dimension_name(fileObj_read) 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) & @@ -477,7 +478,7 @@ subroutine get_file_info(IO_handle, ndim, nvar, ntime) 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) + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) if (len_trim(dim_unlim_name) > 0) & call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) endif @@ -500,8 +501,9 @@ subroutine get_file_times(IO_handle, time_values, ntime) if (present(ntime)) ntime = ntimes if (ntimes > 0) then allocate(time_values(ntimes)) - call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) - call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & + call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) endif end subroutine get_file_times @@ -1747,9 +1749,10 @@ 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 - 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/)) + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & + 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,4 +1938,34 @@ subroutine write_metadata_global(IO_handle, name, attribute) call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) end subroutine write_metadata_global +!> Return unlimited dimension name in file, or empty string if none exists. +function find_unlimited_dimension_name(fileobj) result(label) + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj + !< File handle + character(len=:), allocatable :: label + !< Unlimited dimension name, or empty string if none exists + + integer :: ndims + !< Number of dimensions + character(len=256), allocatable :: dim_names(:) + !< File handle dimension names + integer :: i + !< Loop index + + ndims = get_num_dimensions(fileobj) + allocate(dim_names(ndims)) + call get_dimension_names(fileobj, dim_names) + + do i = 1, ndims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + label = trim(dim_names(i)) + exit + endif + enddo + deallocate(dim_names) + + if (.not. allocated(label)) & + label = '' +end function find_unlimited_dimension_name + end module MOM_io_infra From cd16647c3ae214d80721c322f5a5cf05846597c9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 20 Jun 2023 19:15:28 -0400 Subject: [PATCH 75/81] +Refactor internal_tides interface Refactors the internal tide code in MOM_internal_tides and MOM_diabatic_driver to consolidate it in the MOM_internal_tides module and allow the control structure for that module to be made opaque. This includes moving the internal wave speed diagnostics and the call to wave_speeds or other code setting the internal wave speeds into propagate_int_tide. The get_param calls for INTERNAL_WAVE_CG1_THRESH and UNIFORM_TEST_CG were moved from the diabatic module to the MOM_internal_tides module. The wave_speed_CS and uniform_test_cg were removed from diabatic_CS and added to int_tide_CS. The Nb argument to propagate_int_tide has been made intent inout, as it is now usually set via the call to wave_speeds in that routine, but for certain tests it could use the value passed in from diabatic_driver. All answers are bitwise identical, but there are changes to public interfaces and types, and the order of some entries in the MOM_parameter_doc files and the available_diags files is changed for some cases. --- .../lateral/MOM_internal_tides.F90 | 65 ++++++++++++++++--- .../vertical/MOM_diabatic_driver.F90 | 57 +--------------- 2 files changed, 60 insertions(+), 62 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index ec07939ee4..8c56107a4f 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -23,6 +23,7 @@ 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_speed, only : wave_speeds, wave_speed_CS, wave_speed_init implicit none ; private @@ -33,12 +34,14 @@ module MOM_internal_tides public get_lowmode_loss !> This control structure has parameters for the MOM_internal_tides module -type, public :: int_tide_CS +type, public :: int_tide_CS ; private 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 integer :: nAngle = 24 !< The number of internal tide angular orientations integer :: energized_angle = -1 !< If positive, only this angular band is energized for debugging purposes + real :: uniform_test_cg !< Uniform group velocity of internal tide + !! for testing internal tides [L T-1 ~> m s-1] logical :: corner_adv !< If true, use a corner advection rather than PPM. logical :: upwind_1st !< If true, use a first-order upwind scheme. logical :: simple_2nd !< If true, use a simple second order (arithmetic mean) interpolation @@ -137,11 +140,14 @@ module MOM_internal_tides !< The internal wave energy density as a function of (i,j,angle); temporary for restart real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. + type(wave_speed_CS) :: wave_speed !< Wave speed control structure type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. !>@{ Diag handles ! Diag handles relevant to all modes, frequencies, and angles + integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed + integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds integer :: id_tot_En = -1, id_TKE_itidal_input = -1, id_itide_drag = -1 integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 integer :: id_trans = -1, id_residual = -1 @@ -181,7 +187,7 @@ module MOM_internal_tides !> Calls subroutines in this file that are needed to refract, propagate, !! and dissipate energy density of the internal tide. -subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & +subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -194,16 +200,18 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & !! internal waves [R Z3 T-3 ~> W m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read !! from file [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. + !! In some cases the input values are used, but in + !! others this is set along with the wave speeds. real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure - real, dimension(SZI_(G),SZJ_(G),CS%nMode), & - intent(in) :: cn !< The internal wave speeds of each - !! mode [L T-1 ~> m s-1]. + ! Local variables real, dimension(SZI_(G),SZJ_(G),2) :: & test ! A test unit vector used to determine grid rotation in halos [nondim] + real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & + cn ! baroclinic internal gravity wave speeds for each mode [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] @@ -254,6 +262,18 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & Ub(:,:,:,:) = 0. Umax(:,:,:,:) = 0. + cn(:,:,:) = 0. + + ! Set properties related to the internal tides, such as the wave speeds, storing some + ! of them in the control structure for this module. + if (CS%uniform_test_cg > 0.0) then + do m=1,CS%nMode ; cn(:,:,m) = CS%uniform_test_cg ; enddo + else + call wave_speeds(h, tv, G, GV, US, CS%nMode, cn, CS%wave_speed, & + CS%w_struct, CS%u_struct, CS%u_struct_max, CS%u_struct_bot, & + Nb, CS%int_w2, CS%int_U2, CS%int_N2w2, full_halos=.true.) + endif + ! 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. ! Uncomment if wave_speed is not used to calculate the true values (BDM). @@ -596,6 +616,10 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & call enable_averages(dt, time_end, CS%diag) if (query_averaging_enabled(CS%diag)) then + ! Output internal wave modal wave speeds + if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn(:,:,1),CS%diag) + do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn(:,:,m), CS%diag) ; enddo + ! Output two-dimensional diagnostics if (CS%id_tot_En > 0) call post_data(CS%id_tot_En, tot_En, CS%diag) if (CS%id_itide_drag > 0) call post_data(CS%id_itide_drag, drag_scale, CS%diag) @@ -2292,6 +2316,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) real, dimension(:,:), allocatable :: ridge_temp ! array for temporary storage of flags ! of cells with double-reflecting ridges [nondim] logical :: use_int_tides, use_temperature + real :: IGW_c1_thresh ! A threshold first mode internal wave speed below which all higher + ! mode speeds are not calculated but simply assigned a speed of 0 [L T-1 ~> m s-1]. real :: kappa_h2_factor ! A roughness scaling factor [nondim] real :: RMS_roughness_frac ! The maximum RMS topographic roughness as a fraction of the ! nominal ocean depth, or a negative value for no limit [nondim] @@ -2322,8 +2348,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) use_temperature = .true. call read_param(param_file, "ENABLE_THERMODYNAMICS", use_temperature) if (.not.use_temperature) call MOM_error(FATAL, & - "register_int_tide_restarts: internal_tides only works with "//& - "ENABLE_THERMODYNAMICS defined.") + "internal_tides_init: internal_tides only works with ENABLE_THERMODYNAMICS defined.") ! Set number of frequencies, angles, and modes to consider num_freq = 1 ; num_angle = 24 ; num_mode = 1 @@ -2447,6 +2472,15 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", & units="nondim", default=0.003) + call get_param(param_file, mdl, "INTERNAL_WAVE_CG1_THRESH", IGW_c1_thresh, & + "A minimal value of the first mode internal wave speed below which all higher "//& + "mode speeds are not calculated but are simply reported as 0. This must be "//& + "non-negative for the wave_speeds routine to be used.", & + units="m s-1", default=0.01, scale=US%m_s_to_L_T) + + call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & + "If positive, a uniform group velocity of internal tide for test case", & + default=-1., units="m s-1", scale=US%m_s_to_L_T) call get_param(param_file, mdl, "INTERNAL_TIDE_ENERGIZED_ANGLE", CS%energized_angle, & "If positive, only one angular band of the internal tides "//& "gets all of the energy. (This is for debugging.)", default=-1) @@ -2610,6 +2644,18 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo call pass_var(CS%residual,G%domain) + CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & + Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) + allocate(CS%id_cn(CS%nMode), source=-1) + do m=1,CS%nMode + write(var_name, '("cn_mode",i1)') m + write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m + CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & + Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + enddo + + ! Register maps of reflection parameters CS%id_refl_ang = register_diag_field('ocean_model', 'refl_angle', diag%axesT1, & Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') @@ -2777,6 +2823,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo + ! Initialize the module that calculates the wave speeds. + call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh) + end subroutine internal_tides_init !> This subroutine deallocates the memory associated with the internal tides control structure diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b0d04e434c..1bc29ee16f 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -67,7 +67,6 @@ module MOM_diabatic_driver use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units -use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init use MOM_wave_interface, only : wave_parameters_CS use MOM_stochastics, only : stochastic_CS @@ -123,9 +122,6 @@ module MOM_diabatic_driver !! shear and ePBL diffusivities are used. real :: ePBL_Prandtl !< The Prandtl number used by ePBL to convert vertical !! diffusivities into viscosities [nondim]. - integer :: nMode = 1 !< Number of baroclinic modes to consider - real :: uniform_test_cg !< Uniform group velocity of internal tide - !! for testing internal tides [L T-1 ~> m s-1] logical :: useALEalgorithm !< If true, use the ALE algorithm rather than layered !! isopycnal/stacked shallow water mode. This logical !! passed by argument to diabatic_driver_init. @@ -239,7 +235,6 @@ module MOM_diabatic_driver type(int_tide_CS) :: int_tide !< Internal tide control structure type(opacity_CS) :: opacity !< Opacity control structure type(regularize_layers_CS) :: regularize_layers !< Regularize layer control structure - type(wave_speed_CS) :: wave_speed !< Wave speed control struct type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass type(group_pass_type) :: pass_Kv !< For group halo pass @@ -297,8 +292,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & eta ! Interface heights before diapycnal mixing [Z ~> m] - real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & - cn_IGW ! baroclinic internal gravity wave speeds [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: temp_diag ! Previous temperature for diagnostics [C ~> degC] real, dimension(SZI_(G)) :: T_freeze, & ! The freezing potential temperature at the current salinity [C ~> degC]. ps ! Surface pressure [R L2 T-2 ~> Pa] @@ -392,17 +385,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! This block provides an interface for the unresolved low-mode internal tide module. call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & CS%int_tide_input_CSp) - cn_IGW(:,:,:) = 0.0 - if (CS%uniform_test_cg > 0.0) then - 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, 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, & + call propagate_int_tide(h, tv, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & CS%int_tide_input%Nb, dt, G, GV, US, CS%int_tide) if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides @@ -505,10 +489,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) endif - if (CS%use_int_tides) then - if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn_IGW(:,:,1),CS%diag) - do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn_IGW(:,:,m), CS%diag) ; enddo - endif if (stoch_CS%do_sppt .and. stoch_CS%id_sppt_wts > 0) & call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) @@ -2979,8 +2959,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Local variables real :: Kd ! A diffusivity used in the default for other tracer diffusivities [Z2 T-1 ~> m2 s-1] - real :: IGW_c1_thresh ! A threshold first mode internal wave speed below which all higher - ! mode speeds are not calculated but simply assigned a speed of 0 [L T-1 ~> m s-1]. logical :: use_temperature character(len=20) :: EN1, EN2, EN3 @@ -3073,23 +3051,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & "If true, use the code that advances a separate set of "//& "equations for the internal tide energy density.", default=.false.) - CS%nMode = 1 - if (CS%use_int_tides) then - call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", CS%nMode, & - "The number of distinct internal tide modes "//& - "that will be calculated.", default=1, do_not_log=.true.) - call get_param(param_file, mdl, "INTERNAL_WAVE_CG1_THRESH", IGW_c1_thresh, & - "A minimal value of the first mode internal wave speed below which all higher "//& - "mode speeds are not calculated but are simply reported as 0. This must be "//& - "non-negative for the wave_speeds routine to be used.", & - units="m s-1", default=0.01, scale=US%m_s_to_L_T) - call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & - "If positive, a uniform group velocity of internal tide for test case", & - default=-1., units="m s-1", scale=US%m_s_to_L_T) - endif - - call get_param(param_file, mdl, "MASSLESS_MATCH_TARGETS", & - CS%massless_match_targets, & + + call get_param(param_file, mdl, "MASSLESS_MATCH_TARGETS", CS%massless_match_targets, & "If true, the temperature and salinity of massless layers "//& "are kept consistent with their target densities. "//& "Otherwise the properties of massless layers evolve "//& @@ -3197,19 +3160,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) endif - if (CS%use_int_tides) then - CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & - Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) - allocate(CS%id_cn(CS%nMode), source=-1) - do m=1,CS%nMode - write(var_name, '("cn_mode",i1)') m - write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m - CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & - Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) - call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - enddo - endif - if (use_temperature) then CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff", diag%axesTi, & Time, "Diffusive diapycnal temperature flux across interfaces", & @@ -3504,7 +3454,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call int_tide_input_init(Time, G, GV, US, param_file, diag, CS%int_tide_input_CSp, & CS%int_tide_input) call internal_tides_init(Time, G, GV, US, param_file, diag, CS%int_tide) - call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh) endif physical_OBL_scheme = (CS%use_bulkmixedlayer .or. CS%use_KPP .or. CS%use_energetic_PBL) From 70a75ff7618d3dea4e7e58fb34862d7354050603 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 21 Jun 2023 06:29:36 -0400 Subject: [PATCH 76/81] +Add fluxes%tau_mag and forces%tau_mag Add new allocatable tau_mag arrays to the forcing and mech_forcing types to hold the magnitude of the wind stresses including gustiness contributions. There is also a new tau_mag diagnostic. This same information in tau_mag is being transformed into ustar, but these changes avoid division by the Boussinesq reference density (GV%Rho0), and allow for a more accurate calculation of derived fields when in non-Boussinesq mode, without having to multiply and divide by GV%Rho0. There is also a new optional tau_mag argument to extract_IOB_stresses to support these changes. These new arrays are not being used yet in the MOM6 solutions, but they are being allocated and populated in the routines that set the ustar fields, and they have been tested in changes to the modules that use ustar that will come in a subsequent commit. This commit also adds the new RLZ_T2_to_Pa element to the unit_scale_type to undo the scaling of wind stresses and it makes use of it in some of the new code. All answers are bitwise identical, but there are new arrays or elements in three transparent public types. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 44 ++++++++---- .../mct_cap/mom_surface_forcing_mct.F90 | 4 ++ .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 4 ++ .../solo_driver/MOM_surface_forcing.F90 | 61 +++++++++++----- .../solo_driver/user_surface_forcing.F90 | 5 +- src/core/MOM.F90 | 2 + src/core/MOM_forcing_type.F90 | 70 +++++++++++++++---- src/framework/MOM_unit_scaling.F90 | 2 + 8 files changed, 144 insertions(+), 48 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 f70cd34012..251f37290d 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -624,13 +624,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif ! Set the wind stresses and ustar. - if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless)) then + if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) .and. associated(fluxes%tau_mag)) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar, & - gustless_ustar=fluxes%ustar_gustless) - elseif (associated(fluxes%ustar)) then - call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) - elseif (associated(fluxes%ustar_gustless)) then - call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) + mag_tau=fluxes%tau_mag, gustless_ustar=fluxes%ustar_gustless) + else + if (associated(fluxes%ustar)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) + if (associated(fluxes%ustar_gustless)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) + if (associated(fluxes%tau_mag)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=fluxes%tau_mag) endif if (coupler_type_initialized(fluxes%tr_fluxes) .and. & @@ -674,7 +677,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ real, dimension(SZI_(G),SZJ_(G)) :: & rigidity_at_h, & ! Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] net_mass_src, & ! A temporary of net mass sources [R Z T-1 ~> kg m-2 s-1]. - ustar_tmp ! A temporary array of ustar values [Z T-1 ~> m s-1]. + ustar_tmp, & ! A temporary array of ustar values [Z T-1 ~> m s-1]. + tau_mag_tmp ! A temporary array of surface stress magnitudes [R Z L T-2 ~> Pa] real :: I_GEarth ! The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] real :: Kv_rho_ice ! (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] @@ -778,12 +782,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! Set the wind stresses and ustar. if (wt1 <= 0.0) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=forces%ustar, tau_halo=1) + ustar=forces%ustar, mag_tau=forces%tau_mag, tau_halo=1) else call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=ustar_tmp, tau_halo=1) + ustar=ustar_tmp, mag_tau=tau_mag_tmp, tau_halo=1) do j=js,je ; do i=is,ie forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) + forces%tau_mag(i,j) = wt1*forces%tau_mag(i,j) + wt2*tau_mag_tmp(i,j) enddo ; enddo endif @@ -880,7 +885,7 @@ end subroutine convert_IOB_to_forces !! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign !! conventions, and putting the fields into arrays with MOM-standard sized halos. subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ustar, & - gustless_ustar, tau_halo) + gustless_ustar, mag_tau, tau_halo) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -900,6 +905,9 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: gustless_ustar !< The surface friction velocity without !! any contributions from gustiness [Z T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: mag_tau !< The magintude of the wind stress at tracer points + !! including subgridscale variability and gustiness [R Z L T-2 ~> Pa] integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. ! Local variables @@ -916,7 +924,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - logical :: do_ustar, do_gustless + logical :: do_ustar, do_gustless, do_tau_mag integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, ish, ieh, jsh, jeh, Isqh, Ieqh, Jsqh, Jeqh, i0, j0, halo @@ -929,7 +937,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, IRho0 = US%L_to_Z / CS%Rho0 stress_conversion = US%Pa_to_RLZ_T2 * CS%wind_stress_multiplier - do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) + do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) ; do_tau_mag = present(mag_tau) wind_stagger = CS%wind_stagger if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & @@ -1022,13 +1030,13 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif ! endif for extracting wind stress fields with various staggerings endif - if (do_ustar .or. do_gustless) then + if (do_ustar .or. do_tau_mag .or. do_gustless) then ! Set surface friction velocity directly or as a function of staggering. ! ustar is required for the bulk mixed layer formulation and other turbulent mixing ! parametizations. The background gustiness (for example with a relatively small value ! of 0.02 Pa) is intended to give reasonable behavior in regions of very weak winds. if (associated(IOB%stress_mag)) then - if (do_ustar) then ; do j=js,je ; do i=is,ie + if (do_ustar .or. do_tau_mag) then ; do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d) then if ((wind_stagger == CGRID_NE) .or. & @@ -1038,7 +1046,10 @@ 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*US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0)) + if (do_tau_mag) & + mag_tau(i,j) = gustiness + US%Pa_to_RLZ_T2*IOB%stress_mag(i-i0,j-j0) + if (do_ustar) & + 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 @@ -1062,6 +1073,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else @@ -1074,6 +1086,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else @@ -1095,6 +1108,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (CS%read_gust_2d) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag if (CS%answer_date < 20190101) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) else diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index 9b858af94e..ec5dab57a7 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -774,6 +774,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif + forces%tau_mag(i,j) = gustiness + tau_mag forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo ; enddo @@ -799,6 +800,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) + forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo ; enddo @@ -820,8 +822,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then + forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2) forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else + forces%tau_mag(i,j) = CS%gust_const + sqrt(taux2 + tauy2) forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index b8162b4b59..6d65ae4d28 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -851,6 +851,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif + forces%tau_mag(i,j) = gustiness + tau_mag forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) @@ -876,6 +877,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) + forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) enddo ; enddo @@ -897,8 +899,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then + forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2) forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else + forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2) forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 0e8aedb8d0..859bfd81c8 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -407,10 +407,16 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) enddo ; enddo ; endif + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau + CS%gust(i,j) + enddo ; enddo ; endif else if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust_const ) / CS%Rho0 ) enddo ; enddo ; endif + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau + CS%gust_const + enddo ; enddo ; endif endif call callTree_leave("wind_forcing_const") @@ -522,9 +528,11 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) ! set the friction velocity if (CS%answer_date < 20190101) then do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) forces%ustar(i,j) = sqrt(US%L_to_Z * ((CS%gust_const/CS%Rho0) + & - sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + forces%tauy(i,j)*forces%tauy(i,j) + & - forces%taux(i-1,j)*forces%taux(i-1,j) + forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0) ) + sqrt(0.5*(forces%tauy(i,J-1)*forces%tauy(i,J-1) + forces%tauy(i,J)*forces%tauy(i,J) + & + forces%taux(I-1,j)*forces%taux(I-1,j) + forces%taux(I,j)*forces%taux(I,j)))/CS%Rho0) ) enddo ; enddo else call stresses_to_ustar(forces, G, US, CS) @@ -725,11 +733,12 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt((CS%gust(i,j) + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j))) * US%L_to_Z / CS%Rho0) + forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + forces%ustar(i,j) = sqrt(forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0) enddo ; enddo else do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) enddo ; enddo @@ -772,15 +781,19 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt((CS%gust(i,j) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) ) * US%L_to_Z / CS%Rho0 ) + forces%tau_mag(i,j) = CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) enddo ; enddo else do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) forces%ustar(i,j) = sqrt(US%L_to_Z * ( (CS%gust_const/CS%Rho0) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2)))/CS%Rho0)) + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2)))/CS%Rho0)) enddo ; enddo endif endif @@ -792,6 +805,9 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (read_Ustar) then call MOM_read_data(filename, CS%Ustar_var, forces%ustar(:,:), & G%Domain, timelevel=time_lev, scale=US%m_to_Z*US%T_to_s) + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * forces%ustar(i,j)**2 + enddo ; enddo endif CS%wind_last_lev = time_lev @@ -815,6 +831,7 @@ 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 :: ustar_tmp(SZI_(G),SZJ_(G)) ! The pre-override value of ustar [Z T-1 ~> m s-1] integer :: i, j call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") @@ -840,17 +857,25 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) if (CS%read_gust_2d) then 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) + forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j) + forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) enddo ; enddo else do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%tau_mag(i,j) = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust_const + ! forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) forces%ustar(i,j) = sqrt(US%L_to_Z * (sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)/CS%Rho0 + & CS%gust_const/CS%Rho0)) enddo ; enddo endif + ! Give the data override the option to modify the newly calculated forces%ustar. + ustar_tmp(:,:) = forces%ustar(:,:) call data_override(G%Domain, 'ustar', forces%ustar, day, scale=US%m_to_Z*US%T_to_s) + ! Only reset values where data override of ustar has occurred + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ustar_tmp(i,j) /= forces%ustar(i,j)) then + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * forces%ustar(i,j)**2 + endif ; enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) @@ -875,15 +900,17 @@ subroutine stresses_to_ustar(forces, G, US, CS) if (CS%read_gust_2d) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( (CS%gust(i,j) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) ) * I_rho ) + forces%tau_mag(i,j) = CS%gust(i,j) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * I_rho ) enddo ; enddo else do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( (CS%gust_const + & - sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) + forces%tau_mag(i,j) = CS%gust_const + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) + forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * I_rho ) enddo ; enddo endif diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index 42e732bb73..d7d3b89a8a 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -88,9 +88,10 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! is always positive. if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt((CS%gust_const + & + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gust_const + & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * (US%L_to_Z/CS%Rho0)) + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(forces%tau_mag(i,j) * (US%L_to_Z/CS%Rho0)) enddo ; enddo ; endif end subroutine USER_wind_forcing diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index af8481fd1c..7b9f2f9d3f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -651,6 +651,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call create_group_pass(pass_tau_ustar_psurf, forces%taux, forces%tauy, G%Domain) if (associated(forces%ustar)) & call create_group_pass(pass_tau_ustar_psurf, forces%ustar, G%Domain) + if (associated(forces%tau_mag)) & + call create_group_pass(pass_tau_ustar_psurf, forces%tau_mag, G%Domain) if (associated(forces%p_surf)) & call create_group_pass(pass_tau_ustar_psurf, forces%p_surf, G%Domain) if (G%nonblocking_updates) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9a5e1f48f5..a59c33d525 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -68,6 +68,9 @@ module MOM_forcing_type ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. + tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, + !! including any contributions from sub-gridscale variability + !! or gustiness [R L Z T-2 ~> Pa] ustar_gustless => NULL() !< surface friction velocity scale without any !! any augmentation for gustiness [Z T-1 ~> m s-1]. @@ -222,6 +225,8 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & taux => NULL(), & !< zonal wind stress [R L Z T-2 ~> Pa] tauy => NULL(), & !< meridional wind stress [R L Z T-2 ~> Pa] + tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, including any + !! contributions from sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. net_mass_src => NULL() !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] @@ -359,6 +364,7 @@ module MOM_forcing_type integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 + integer :: id_tau_mag = -1 integer :: id_psurf = -1 integer :: id_TKE_tidal = -1 @@ -1083,6 +1089,8 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) ! and js...je as their extent. if (associated(fluxes%ustar)) & call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%tau_mag)) & + call hchksum(fluxes%tau_mag, mesg//" fluxes%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) if (associated(fluxes%buoy)) & call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%sw)) & @@ -1186,11 +1194,13 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! and js...je as their extent. if (associated(forces%taux) .and. associated(forces%tauy)) & call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & - haloshift=hshift, symmetric=.true., scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + haloshift=hshift, symmetric=.true., scale=US%RLZ_T2_to_Pa) if (associated(forces%p_surf)) & call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) if (associated(forces%ustar)) & call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call hchksum(forces%tau_mag, mesg//" forces%tau_mag", G%HI, haloshift=hshift, scale=US%RLZ_T2_to_Pa) if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true., & @@ -1237,6 +1247,7 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) write(0,'(2a)') 'MOM_forcing_type, forcing_SinglePointPrint: Called from ',mesg write(0,'(a,2es15.3)') 'MOM_forcing_type, forcing_SinglePointPrint: lon,lat = ',G%geoLonT(i,j),G%geoLatT(i,j) call locMsg(fluxes%ustar,'ustar') + call locMsg(fluxes%tau_mag,'tau_mag') call locMsg(fluxes%buoy,'buoy') call locMsg(fluxes%sw,'sw') call locMsg(fluxes%sw_vis_dir,'sw_vis_dir') @@ -1305,18 +1316,22 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_taux = register_diag_field('ocean_model', 'taux', diag%axesCu1, Time, & 'Zonal surface stress from ocean interactions with atmos and ice', & - 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & + 'Pa', conversion=US%RLZ_T2_to_Pa, & standard_name='surface_downward_x_stress', cmor_field_name='tauuo', & cmor_units='N m-2', cmor_long_name='Surface Downward X Stress', & cmor_standard_name='surface_downward_x_stress') handles%id_tauy = register_diag_field('ocean_model', 'tauy', diag%axesCv1, Time, & 'Meridional surface stress ocean interactions with atmos and ice', & - 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & + 'Pa', conversion=US%RLZ_T2_to_Pa, & standard_name='surface_downward_y_stress', cmor_field_name='tauvo', & cmor_units='N m-2', cmor_long_name='Surface Downward Y Stress', & cmor_standard_name='surface_downward_y_stress') + handles%id_tau_mag = register_diag_field('ocean_model', 'tau_mag', diag%axesT1, Time, & + 'Average magnitude of the wind stress including contributions from gustiness', & + 'Pa', conversion=US%RLZ_T2_to_Pa) + handles%id_ustar = register_diag_field('ocean_model', 'ustar', diag%axesT1, Time, & 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & 'm s-1', conversion=US%Z_to_m*US%s_to_T) @@ -2046,6 +2061,7 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) + fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*forces%tau_mag(i,j) enddo ; enddo else do j=js,je ; do i=is,ie @@ -2053,6 +2069,7 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%p_surf_full(i,j) = flux_tmp%p_surf_full(i,j) fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*flux_tmp%ustar(i,j) + fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*flux_tmp%tau_mag(i,j) enddo ; enddo endif @@ -2173,6 +2190,12 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) enddo ; enddo endif + if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then + do j=js,je ; do i=is,ie + fluxes%tau_mag(i,j) = forces%tau_mag(i,j) + enddo ; enddo + endif + if (do_pres) then if (associated(forces%p_surf) .and. associated(fluxes%p_surf)) then do j=js,je ; do i=is,ie @@ -2304,6 +2327,12 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) enddo ; enddo endif + if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = fluxes%tau_mag(i,j) + enddo ; enddo + endif + end subroutine copy_back_forcing_fields !> Offer mechanical forcing fields for diagnostics for those @@ -2946,6 +2975,9 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_buoy > 0) .and. associated(fluxes%buoy)) & call post_data(handles%id_buoy, fluxes%buoy, diag) + if ((handles%id_tau_mag > 0) .and. associated(fluxes%tau_mag)) & + call post_data(handles%id_tau_mag, fluxes%tau_mag, diag) + if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & call post_data(handles%id_ustar, fluxes%ustar, diag) @@ -3015,6 +3047,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%ustar,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) + call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%evap,isd,ied,jsd,jed, water) call myAlloc(fluxes%lprec,isd,ied,jsd,jed, water) @@ -3150,6 +3183,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%tauy,isd,ied,JsdB,JedB, stress) call myAlloc(forces%ustar,isd,ied,jsd,jed, ustar) + call myAlloc(forces%tau_mag,isd,ied,jsd,jed, ustar) call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) @@ -3218,8 +3252,7 @@ subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & ! to some degree. But since this would be enforced at the driver level, ! we handle them here as independent flags. - ustar = associated(fluxes%ustar) & - .and. associated(fluxes%ustar_gustless) + ustar = associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) ! TODO: Check for all associated fields, but for now just check one as a marker water = associated(fluxes%evap) heat = associated(fluxes%seaice_melt_heat) @@ -3276,6 +3309,7 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%ustar)) deallocate(fluxes%ustar) if (associated(fluxes%ustar_gustless)) deallocate(fluxes%ustar_gustless) + if (associated(fluxes%tau_mag)) deallocate(fluxes%tau_mag) if (associated(fluxes%buoy)) deallocate(fluxes%buoy) if (associated(fluxes%sw)) deallocate(fluxes%sw) if (associated(fluxes%seaice_melt_heat)) deallocate(fluxes%seaice_melt_heat) @@ -3334,9 +3368,10 @@ end subroutine deallocate_forcing_type subroutine deallocate_mech_forcing(forces) type(mech_forcing), intent(inout) :: forces !< Forcing fields structure - if (associated(forces%taux)) deallocate(forces%taux) - if (associated(forces%tauy)) deallocate(forces%tauy) - if (associated(forces%ustar)) deallocate(forces%ustar) + if (associated(forces%taux)) deallocate(forces%taux) + if (associated(forces%tauy)) deallocate(forces%tauy) + if (associated(forces%ustar)) deallocate(forces%ustar) + if (associated(forces%tau_mag)) deallocate(forces%tau_mag) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) @@ -3365,6 +3400,7 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) if (do_ustar) then call rotate_array(fluxes_in%ustar, turns, fluxes%ustar) call rotate_array(fluxes_in%ustar_gustless, turns, fluxes%ustar_gustless) + call rotate_array(fluxes_in%tau_mag, turns, fluxes%tau_mag) endif if (do_water) then @@ -3495,8 +3531,10 @@ subroutine rotate_mech_forcing(forces_in, turns, forces) call rotate_vector(forces_in%taux, forces_in%tauy, turns, & forces%taux, forces%tauy) - if (do_ustar) & + if (do_ustar) then call rotate_array(forces_in%ustar, turns, forces%ustar) + call rotate_array(forces_in%tau_mag, turns, forces%tau_mag) + endif if (do_shelf) then call rotate_array_pair( & @@ -3555,24 +3593,27 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) do_press, do_iceberg) if (do_stress) then - tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) + tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%RLZ_T2_to_Pa) do j=js,je ; do i=isB,ieB if (G%mask2dCu(I,j) > 0.0) forces%taux(I,j) = tx_mean enddo ; enddo - ty_mean = global_area_mean_v(forces%tauy, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) + ty_mean = global_area_mean_v(forces%tauy, G, tmp_scale=US%RLZ_T2_to_Pa) do j=jsB,jeB ; do i=is,ie if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean enddo ; enddo if (tau2ustar) then - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.0) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*Irho0) - enddo ; enddo + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%tau_mag(i,j) = sqrt(tx_mean**2 + ty_mean**2) + forces%ustar(i,j) = sqrt(forces%tau_mag(i,j) * Irho0) + endif ; enddo ; enddo else call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) endif else if (do_ustar) then call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) endif endif @@ -3613,6 +3654,7 @@ subroutine homogenize_forcing(fluxes, G, GV, US) if (do_ustar) then call homogenize_field_t(fluxes%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) call homogenize_field_t(fluxes%ustar_gustless, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) endif if (do_water) then diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 482c2eec7a..868352102e 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -52,6 +52,7 @@ 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] + real :: RLZ_T2_to_Pa !< Convert wind stresses from R L Z T-2 to Pa [Pa T2 R-1 L-1 Z-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] @@ -221,6 +222,7 @@ subroutine set_unit_scaling_combos(US) US%RL2_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 ! Wind stresses: + US%RLZ_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 * US%Z_to_L 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 b0289feaa4b7fb2f0a406d16bdf507769d6849e6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 24 Jun 2023 12:10:29 -0400 Subject: [PATCH 77/81] *+Fix problems in mixedlayer_restrat_Bodner Fixed several problems with the recently added Bodner mixed layer restratification parameterization code. - Corrected the dimensional rescaling in the expressions for psi_mag by adding a missing factor of US%L_to_Z. - A logical branch was added based on the correct mask for land or OBC points to avoid potentially ill-defined calculations of the magnitude of the Bodner parameterization streamfunction, some which were leading to NaNs. - Set a tiny but nonzero default value for MIN_WSTAR2 to avoid NaNs in some calculations of the streamfunction magnitude. - Revised the expression for dd within the mu function in a mathematically equivalent way to avoid any possibility of taking a fractional exponential power of a tiny negative number due to truncation errors, which was leading to NaNs in some cases while developing and debugging the other changes that are not included in this commit. This does not appear to change any answers in the existing test cases, perhaps because the mixed layer restratification "tail" is not being activated by setting TAIL_DH to be larger than 0. - Corrected or added variable units in comments in the mixedlayer_restrat control structure. These could change answers (and avoid NaNs) in some cases with USE_BODNER23=True, MLE_TAIL_DH > 0 or MLE%TAIL_DH > 0, and there will be changes to the MOM_parameter_doc files for some cases, but given how recently this code was added, it is expected that all answers are bitwise identical in the existing test cases. --- .../lateral/MOM_mixed_layer_restrat.F90 | 79 ++++++++++--------- 1 file changed, 43 insertions(+), 36 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 12f494fc8a..206773ecb0 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -62,24 +62,25 @@ module MOM_mixed_layer_restrat ! 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 :: Cr !< Efficiency coefficient from Bodner et al., 2023 [nondim] 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 :: min_wstar2 !< The minimum lower bound to apply to the vertical momentum flux, + !! w'u', in the Bodner et al., restratification parameterization + !! [m2 s-2]. This avoids a division-by-zero in the limit when u* + !! and the buoyancy flux are zero. 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] + !! depth (BLD) when the BLD is deeper than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of BLD. 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. + !! depth (BLD) when the BLD is shallower than the running mean [T ~> s]. + !! 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] + !! MLD, when the latter is shallower than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of MLD. 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] + !! MLD, when the latter is deeper than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of MLD. logical :: debug = .false. !< If true, calculate checksums of fields for debugging. @@ -153,7 +154,7 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, bflux, VarMix, else ! 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 + endif end subroutine mixedlayer_restrat @@ -668,7 +669,7 @@ real function mu(sigma, 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) + dd = (max(1. - xp**2 * (3. - 2.*xp), 0.))**(1. + 2.*dh) ! -0.5 < sigma : bottop(sigma)=0 (upper half of mixed layer) ! sigma < -0.5 : bottop(sigma)=1 (below upper half) @@ -869,16 +870,18 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! 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 + if (G%OBCmaskCu(I,j) > 0.) then + grid_dsd = sqrt(0.5*( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 )) * G%dyCu(I,j) ! L2 ~> m2 + 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 * US%L_to_Z * GV%Z_to_H + else ! There is no flux on land and no gradient at open boundary points. + psi_mag = 0.0 + endif IhTot = 2.0 / ((htot(i,j) + htot(i+1,j)) + h_neglect) ! [H-1] sigint = 0.0 @@ -908,16 +911,18 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! 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 + if (G%OBCmaskCv(i,J) > 0.) then + grid_dsd = sqrt(0.5*( G%dxCv(i,J)**2 + G%dyCv(i,J)**2 )) * G%dxCv(i,J) ! L2 ~> m2 + 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 * US%L_to_Z * GV%Z_to_H + else ! There is no flux on land and no gradient at open boundary points. + psi_mag = 0.0 + endif IhTot = 2.0 / ((htot(i,j) + htot(i,j+1)) + h_neglect) ! [H-1] sigint = 0.0 @@ -1403,8 +1408,10 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 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.) + "a division-by-zero in the limit when u* and the buoyancy flux are zero. "//& + "The default is less than the molecular viscosity of water times the Coriolis "//& + "parameter a micron away from the equator.", & + units="m2 s-2", default=1.0e-24) 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 "//& From d44c228eefd909d21367832446c6d8be16d8800b Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 29 Jun 2023 14:46:02 -0400 Subject: [PATCH 78/81] FMS2: New interface to set/nullify_domain This patch adds wrappers to the set_domain and nullify_domain functions used in FMS1 for internal FMS IO operations. These are not used in FMS2, so the wrapper functions are empty. This is required to eliminate FMS1 IO dependencies in SIS2. --- config_src/infra/FMS1/MOM_domain_infra.F90 | 16 ++++++++++++++++ config_src/infra/FMS2/MOM_domain_infra.F90 | 14 ++++++++++++++ 2 files changed, 30 insertions(+) diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 2a00abe32d..2c97a0bb31 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -24,6 +24,8 @@ module MOM_domain_infra 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_mod, only : fms_set_domain => set_domain +use fms_io_mod, only : fms_nullify_domain => nullify_domain 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 @@ -49,6 +51,7 @@ module MOM_domain_infra public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: set_domain, nullify_domain ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. ! public :: global_field_sum, BITWISE_EXACT_SUM @@ -1998,4 +2001,17 @@ subroutine get_layout_extents(Domain, extent_i, extent_j) call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) end subroutine get_layout_extents +!> Set the associated domain for internal FMS I/O operations. +subroutine set_domain(Domain) + type(MOM_domain_type), intent(in) :: Domain + !< MOM domain to be designated as the internal FMS I/O domain + + call fms_set_domain(Domain%mpp_domain) +end subroutine set_domain + +!> Free the associated domain for internal FMS I/O operations. +subroutine nullify_domain + call fms_nullify_domain +end subroutine nullify_domain + end module MOM_domain_infra diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index de580d98d9..ff1d888c47 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -49,6 +49,7 @@ module MOM_domain_infra public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: set_domain, nullify_domain ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. ! public :: global_field_sum, BITWISE_EXACT_SUM @@ -2002,4 +2003,17 @@ subroutine get_layout_extents(Domain, extent_i, extent_j) call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) end subroutine get_layout_extents +!> Set the associated domain for internal FMS I/O operations. +subroutine set_domain(Domain) + type(MOM_domain_type), intent(in) :: Domain + !< MOM domain to be designated as the internal FMS I/O domain + + ! FMS2 does not have domain-based internal FMS I/O operations, so this + ! function does nothing. +end subroutine set_domain + +subroutine nullify_domain + ! No internal FMS I/O domain can be assigned, so this function does nothing. +end subroutine nullify_domain + end module MOM_domain_infra From 859ac15483f609249e839d206eb33da14df7d1ad Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 10 Jul 2023 18:26:30 -0400 Subject: [PATCH 79/81] *Correct nuopc_cap tau_mag bug Correct a recently added bug in the expression for tau_mag in the nuopc_cap version of convert_IOB_to_forces, where CS%gust(i,j) was used in place of CS%gust_const, even though the 2-d array was not being set. This commit changes answers in some recent versions of the code back to what they had been previously, and it addresses concerns that had been raised with the first version of gfdl-candidate-2023-07-03 and its PR to the main version of MOM6. --- config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 6d65ae4d28..0d2a73aa64 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -902,7 +902,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2) forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else - forces%tau_mag(i,j) = CS%gust(i,j) + sqrt(taux2 + tauy2) + forces%tau_mag(i,j) = CS%gust_const + sqrt(taux2 + tauy2) forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo From 0bcf0312391992f63ee28f98bb2571c3a675be93 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 19 Jul 2023 21:15:57 -0400 Subject: [PATCH 80/81] Fms2 io read3d slice (#399) * Restore functionality for reading slices from 3d volumes in MOM_io - The recent MOM_io modifications in support of FMS2_io accidentally removed support for reading on-grid data (same horizontal grid as model) k-slices. This is needed in some configurations in the model state initialization. * Add FMS1 interfaces * Additional patches to enable reading ongrid state initialization data - read local 3d volume rather than attempting to slice ongrid data vertically. - Related bugfixes in MOM_io --- config_src/infra/FMS1/MOM_coms_infra.F90 | 24 ++- config_src/infra/FMS1/MOM_io_infra.F90 | 41 +++++- config_src/infra/FMS2/MOM_coms_infra.F90 | 23 ++- config_src/infra/FMS2/MOM_io_infra.F90 | 70 ++++++++- src/framework/MOM_horizontal_regridding.F90 | 20 ++- src/framework/MOM_io.F90 | 154 +++++++++++++++++++- 6 files changed, 322 insertions(+), 10 deletions(-) diff --git a/config_src/infra/FMS1/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90 index 939161875e..13f8006184 100644 --- a/config_src/infra/FMS1/MOM_coms_infra.F90 +++ b/config_src/infra/FMS1/MOM_coms_infra.F90 @@ -25,7 +25,7 @@ module MOM_coms_infra !> Communicate an array, string or scalar from one PE to others interface broadcast module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D - module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D end interface broadcast !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -260,6 +260,28 @@ subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) end subroutine broadcast_real2D + +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + ! field_chksum wrappers !> Compute a checksum for a field distributed over a PE list. If no PE list is diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index c0ccfcbcc8..e37e5db3cb 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -57,7 +57,7 @@ module MOM_io_infra !> Read a data field from a file interface read_field module procedure read_field_4d - module procedure read_field_3d + module procedure read_field_3d, read_field_3d_region module procedure read_field_2d, read_field_2d_region module procedure read_field_1d, read_field_1d_int module procedure read_field_0d, read_field_0d_int @@ -696,6 +696,45 @@ subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & endif ; endif end subroutine read_field_3d +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + if (present(MOM_Domain)) then + 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 + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif + endif ; endif +end subroutine read_field_3d_region + + !> This routine uses the fms_io subroutine read_data to read a distributed !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 index 939161875e..cf9a724734 100644 --- a/config_src/infra/FMS2/MOM_coms_infra.F90 +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -25,7 +25,7 @@ module MOM_coms_infra !> Communicate an array, string or scalar from one PE to others interface broadcast module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D - module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D end interface broadcast !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -260,6 +260,27 @@ subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) end subroutine broadcast_real2D +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + ! field_chksum wrappers !> Compute a checksum for a field distributed over a PE list. If no PE list is diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 99d0ac3345..a43b4e9344 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -66,7 +66,7 @@ module MOM_io_infra !> Read a data field from a file interface read_field module procedure read_field_4d - module procedure read_field_3d + module procedure read_field_3d, read_field_3d_region module procedure read_field_2d, read_field_2d_region module procedure read_field_1d, read_field_1d_int module procedure read_field_0d, read_field_0d_int @@ -1030,6 +1030,74 @@ subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & end subroutine read_field_3d +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 3 + !! dimensions. For this 3-d read, the + !! 4th value is always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + 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)) 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)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_2d_region: ", & + filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj_DD, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + 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)) + + ! 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_2d_region: ", filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif + endif ; endif + +end subroutine read_field_3d_region + !> This routine uses the fms_io subroutine read_data to read a distributed !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 883653d715..34d0b73cb9 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -309,6 +309,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its !! native horizontal grid, with units that change !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:,:), allocatable :: tr_in_full !< A 3-d array for holding input data on the + !! model horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles !! with units that change as the input data is !! interpreted [a] then [A ~> a] @@ -448,6 +451,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr if (is_ongrid) then allocate(tr_in(is:ie,js:je), source=0.0) + allocate(tr_in_full(is:ie,js:je,kd), source=0.0) allocate(mask_in(is:ie,js:je), source=0.0) else call horizontal_interp_init() @@ -470,14 +474,19 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr ! Loop through each data level and interpolate to model grid. ! After interpolating, fill in points which will be needed to define the layers. + + if (is_ongrid) then + start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = 1 + count(1) = ie-is+1 ; count(2) = je-js+1 ; count(3) = kd ; start(4) = 1 ; count(4) = 1 + call MOM_read_data(trim(filename), trim(varnam), tr_in_full, start, count, G%Domain) + endif + do k=1,kd mask_in(:,:) = 0.0 tr_out(:,:) = 0.0 if (is_ongrid) then - start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k - count(1) = ie-is+1 ; count(2) = je-js+1 ; count(3) = 1 ; start(4) = 1 ; count(4) = 1 - call MOM_read_data(trim(filename), trim(varnam), tr_in, start, count, G%Domain) + tr_in(is:ie,js:je) = tr_in_full(is:ie,js:je,k) do j=js,je do i=is,ie if (abs(tr_in(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then @@ -594,7 +603,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr enddo ! kd - deallocate(lon_in, lat_in) + if (allocated(lat_inp)) deallocate(lat_inp) + deallocate(tr_in) + if (allocated(tr_inp)) deallocate(tr_inp) + if (allocated(tr_in_full)) deallocate(tr_in_full) end subroutine horiz_interp_and_extrap_tracer_record diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index bebce6f502..220a7d6bcf 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -100,6 +100,7 @@ module MOM_io module procedure MOM_read_data_2d module procedure MOM_read_data_2d_region module procedure MOM_read_data_3d + module procedure MOM_read_data_3d_region module procedure MOM_read_data_4d end interface MOM_read_data @@ -137,7 +138,7 @@ module MOM_io interface read_variable module procedure read_variable_0d, read_variable_0d_int module procedure read_variable_1d, read_variable_1d_int - module procedure read_variable_2d + module procedure read_variable_2d, read_variable_3d end interface read_variable !> Read a global or variable attribute from a named netCDF file using netCDF calls @@ -1161,7 +1162,7 @@ subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) allocate(field_nread(field_ndims)) field_nread(:2) = field_shape(:2) field_nread(3:) = 1 - if (present(nread)) field_shape(:2) = nread(:2) + if (present(nread)) field_nread(:2) = nread(:2) rc = nf90_get_var(ncid, varid, var, field_start, field_nread) @@ -1182,6 +1183,119 @@ subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) call broadcast(var, size(var), blocking=.true.) end subroutine read_variable_2d + +subroutine read_variable_3d(filename, varname, var, start, nread, ncid_in) + character(len=*), intent(in) :: filename !< Name of file to be read + character(len=*), intent(in) :: varname !< Name of variable to be read + real, intent(out) :: var(:,:,:) !< Output array of variable [arbitrary] + integer, optional, intent(in) :: start(:) !< Starting index on each axis. + integer, optional, intent(in) :: nread(:) !< Number of values to be read along each axis + integer, optional, intent(in) :: ncid_in !< netCDF ID of an opened file. + !! If absent, the file is opened and closed within this routine. + + integer :: ncid, varid + integer :: field_ndims, dim_len + integer, allocatable :: field_dimids(:), field_shape(:) + integer, allocatable :: field_start(:), field_nread(:) + integer :: i, rc + character(len=*), parameter :: hdr = "read_variable_3d: " + + ! Validate shape of start and nread + if (present(start)) then + if (size(start) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start must have at least two dimensions.") + endif + + if (present(nread)) then + if (size(nread) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread must have at least two dimensions.") + + if (any(nread(3:) > 1)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread may only read a single level in higher dimensions.") + endif + + ! Since start and nread may be reshaped, we cannot rely on netCDF to ensure + ! that their lengths are equivalent, and must do it here. + if (present(start) .and. present(nread)) then + if (size(start) /= size(nread)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start and nread must have the same length.") + endif + + ! Open and read `varname` from `filename` + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_Read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + + ! Query for the dimensionality of the input field + rc = nf90_inquire_variable(ncid, varid, ndims=field_ndims) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + ! Confirm that field is at least 2d + if (field_ndims < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) // " " // & + trim(varname) // " from " // trim(filename) // " is not a 2D field.") + + ! If start and nread are present, then reshape them to match field dims + if (present(start) .or. present(nread)) then + allocate(field_shape(field_ndims)) + allocate(field_dimids(field_ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=field_dimids) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + do i = 1, field_ndims + rc = nf90_inquire_dimension(ncid, field_dimids(i), len=dim_len) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // ": Difficulties reading dimensions from " // trim(filename)) + field_shape(i) = dim_len + enddo + + ! Reshape start(:) and nreads(:) in case ranks differ + allocate(field_start(field_ndims)) + field_start(:) = 1 + if (present(start)) then + dim_len = min(size(start), size(field_start)) + field_start(:dim_len) = start(:dim_len) + endif + + allocate(field_nread(field_ndims)) + field_nread(:3) = field_shape(:3) + !field_nread(3:) = 1 + if (present(nread)) field_nread(:3) = nread(:3) + + rc = nf90_get_var(ncid, varid, var, field_start, field_nread) + + deallocate(field_start) + deallocate(field_nread) + deallocate(field_shape) + deallocate(field_dimids) + else + rc = nf90_get_var(ncid, varid, var) + endif + + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_3d + !> Read a character-string global or variable attribute subroutine read_attribute_str(filename, attname, att_val, varname, found, all_read, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read @@ -2198,6 +2312,42 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & endif end subroutine MOM_read_data_3d +!> Read a 3d region array from file using infrastructure I/O. +subroutine MOM_read_data_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale, turns) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + integer, dimension(:), intent(in) :: start !< Starting index for each axis. + integer, dimension(:), intent(in) :: nread !< Number of values to read along each axis. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition + logical, optional, intent(in) :: no_domain !< If true, field does not use + !! domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + integer, optional, intent(in) :: turns !< Number of quarter turns from + !! input to model grid + + integer :: qturns ! Number of quarter turns + real, allocatable :: data_in(:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call read_field(filename, fieldname, data, start, nread, & + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale & + ) + else + call allocate_rotated_array(data, [1,1,1], -qturns, data_in) + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain%domain_in, no_domain=no_domain, scale=scale & + ) + call rotate_array(data_in, qturns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_3d_region !> Read a 4d array from file using infrastructure I/O. subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & From 82acb2f81e0095fcd289314afbf7bee56520f49c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 2 Aug 2023 12:29:11 -0400 Subject: [PATCH 81/81] Update MOM_variables.F90 --- src/core/MOM_variables.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index bec93376af..280ea0d9ed 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -261,7 +261,7 @@ module MOM_variables ! 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(:,:) :: sfc_buoy_flx !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. + real, pointer, dimension(:,:) :: sfc_buoy_flx => NULL() !< 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].